From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:48:02 +0000 (+0000) Subject: Get of fam inst index in ifaces X-Git-Tag: After_FC_branch_merge~14 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=0cb269be72ffe42498c74d5be845eb27d8818423 Get of fam inst index in ifaces Mon Sep 18 19:40:42 EDT 2006 Manuel M T Chakravarty * Get of fam inst index in ifaces Fri Sep 8 16:31:26 EDT 2006 Manuel M T Chakravarty * Get of fam inst index in ifaces - Removes the explicit index to get unique names for derived tycons for family instances again, following a suggestion by SPJ. - We now derive the coercion tycon name from the name of the representation tycon, which is in the iface anyways. *** WARNING: Change of interface file format! *** *** Recompile from scratch! *** --- diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 9319c67..1440525 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -443,6 +443,7 @@ mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" mkNewTyCoOcc = mk_simple_deriv tcName "Co" +mkInstTyCoOcc = mk_simple_deriv tcName "Co" -- derived from rep ty -- Generic derivable classes mkGenOcc1 = mk_simple_deriv varName "$gfrom" @@ -478,24 +479,15 @@ mkLocalOcc uniq occ -- that need encoding (e.g. 'z'!) \end{code} -\begin{code} +Derive a name for the representation type constructor of a data/newtype +instance. --- Derive a name for the representation type constructor of a data/newtype --- instance. --- +\begin{code} mkInstTyTcOcc :: Int -- Index - -> OccName -- Local name (e.g. "Map") + -> OccName -- Family name (e.g. "Map") -> OccName -- Nice unique version (":R23Map") mkInstTyTcOcc index occ = mk_deriv varName (":R" ++ show index) (occNameString occ) - --- Derive a name for the coercion of a data/newtype instance. --- -mkInstTyCoOcc :: Int -- Index - -> OccName -- Local name (e.g. "Map") - -> OccName -- Nice unique version (":Co23Map") -mkInstTyCoOcc index occ - = mk_deriv varName (":Co" ++ show index) (occNameString occ) \end{code} \begin{code} diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 8093c08..6384ddc 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -69,9 +69,7 @@ buildAlgTyCon :: Name -> [TyVar] -> RecFlag -> Bool -- True <=> want generics functions -> Bool -- True <=> was declared in GADT syntax - -> Maybe (TyCon, [Type], - Int) -- Just (family, tys, index) - -- <=> instance of `family' at `tys' + -> Maybe (TyCon, [Type]) -- family instance if applicable -> TcRnIf m n TyCon buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn @@ -79,8 +77,8 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn = do { -- We need to tie a knot as the coercion of a data instance depends -- on the instance representation tycon and vice versa. ; tycon <- fixM (\ tycon_rec -> do - { (final_name, parent) <- maybeComputeFamilyInfo mb_family tycon_rec - ; let { tycon = mkAlgTyCon final_name kind tvs stupid_theta rhs + { parent <- parentInfo mb_family tycon_rec + ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs fields parent is_rec want_generics gadt_syn ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; fields = mkTyConSelIds tycon rhs @@ -91,31 +89,24 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn } where -- If a family tycon with instance types is given, the current tycon is an - -- instance of that family and we have to perform three extra tasks: + -- instance of that family and we need to -- - -- (1) The instance tycon (representing the family at a particular type - -- instance) need to get a new, derived name - we may not reuse the - -- family name. - -- (2) Create a coercion that identifies the family instance type and the + -- (1) create a coercion that identifies the family instance type and the -- representation type from Step (1); ie, it is of the form -- `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion, - -- `F' the family tycon and `R' the (derived) representation tycon. - -- (3) Produce a `AlgTyConParent' value containing the parent and coercion + -- `F' the family tycon and `R' the (derived) representation tycon, + -- and + -- (2) produce a `AlgTyConParent' value containing the parent and coercion -- information. -- - maybeComputeFamilyInfo Nothing rep_tycon = - return (tc_name, NoParentTyCon) - maybeComputeFamilyInfo (Just (family, instTys, index)) rep_tycon = - do { -- (1) New, derived name for the instance tycon - ; final_name <- newImplicitBinder tc_name (mkInstTyTcOcc index) - - -- (2) Create the coercion. - ; co_tycon_name <- newImplicitBinder tc_name (mkInstTyCoOcc index) + parentInfo Nothing rep_tycon = + return NoParentTyCon + parentInfo (Just (family, instTys)) rep_tycon = + do { -- Create the coercion + ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc ; let co_tycon = mkDataInstCoercion co_tycon_name tvs family instTys rep_tycon - - -- (3) Produce parent information. - ; return (final_name, FamilyTyCon family instTys co_tycon index) + ; return $ FamilyTyCon family instTys co_tycon } diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 5f9c1d8..bf62095 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -87,8 +87,7 @@ data IfaceDecl -- current compilation unit ifFamInst :: Maybe -- Just _ <=> instance of fam (IfaceTyCon, -- Family tycon - [IfaceType], -- Instance types - Int ) -- Unique index for naming + [IfaceType]) -- Instance types } | IfaceSyn { ifName :: OccName, -- Type constructor @@ -284,10 +283,9 @@ pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec pprGen True = ptext SLIT("Generics: yes") pprGen False = ptext SLIT("Generics: no") -pprFamily Nothing = ptext SLIT("FamilyInstance: none") -pprFamily (Just (fam, tys, index)) = ptext SLIT("FamilyInstance:") <+> - ppr fam <+> hsep (map ppr tys) <+> - brackets (ppr index) +pprFamily Nothing = ptext SLIT("FamilyInstance: none") +pprFamily (Just (fam, tys)) = ptext SLIT("FamilyInstance:") <+> + ppr fam <+> hsep (map ppr tys) instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty @@ -556,10 +554,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- over the constructors (any more), but they do scope -- over the stupid context in the IfaceConDecls where - Nothing `eqIfTc_fam` Nothing = Equal - (Just (fam1, tys1, co1)) `eqIfTc_fam` (Just (fam2, tys2, co2)) = - fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 &&& bool (co1 == co2) - _ `eqIfTc_fam` _ = NotEqual + Nothing `eqIfTc_fam` Nothing = Equal + (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = + fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 + _ `eqIfTc_fam` _ = NotEqual eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 21332fa..ba72c25 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -409,9 +409,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifaceDeclSubBndrs _other = [] -- coercion for data/newtype family instances -famInstCo Nothing baseOcc = [] -famInstCo (Just (_, _, index)) baseOcc = [mkInstTyTcOcc index baseOcc, - mkInstTyCoOcc index baseOcc] +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] \end{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3bc9257..2069f89 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -191,7 +191,7 @@ import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, tyConArity, tyConTyVars, algTyConRhs, tyConExtName, - tyConFamInst_maybe, tyConFamInstIndex ) + tyConFamInst_maybe ) import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec, dataConTheta, @@ -1036,8 +1036,7 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, ifGeneric = tyConHasGenerics tycon, - ifFamInst = famInstToIface (tyConFamInst_maybe tycon) - (tyConFamInstIndex tycon) } + ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, @@ -1088,9 +1087,9 @@ tyThingToIfaceDecl ext (ATyCon tycon) to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] - famInstToIface Nothing _ = Nothing - famInstToIface (Just (famTyCon, instTys)) index = - Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys, index) + famInstToIface Nothing = Nothing + famInstToIface (Just (famTyCon, instTys)) = + Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys) tyThingToIfaceDecl ext (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 68abd23..6c197cc 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -371,11 +371,11 @@ tcIfaceDecl (IfaceData {ifName = occ_name, { stupid_theta <- tcIfaceCtxt ctxt ; famInst <- case mb_family of - Nothing -> return Nothing - Just (fam, tys, index) -> + Nothing -> return Nothing + Just (fam, tys) -> do { famTyCon <- tcIfaceTyCon fam ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys, index) + ; return $ Just (famTyCon, insttys) } ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; buildAlgTyCon tc_name tyvars stupid_theta diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 1d093e2..7828394 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -38,7 +38,7 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName ) where #include "HsVersions.h" @@ -66,11 +66,13 @@ import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) +import Name ( Name, NamedThing(..), getSrcLoc, nameModule, + nameOccName ) import PrelNames ( thFAKE ) import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) +import OccName ( mkDFunOcc, occNameString, mkInstTyTcOcc ) +import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), + ExternalPackageState(..) ) import SrcLoc ( SrcLoc, Located(..) ) import Outputable \end{code} @@ -611,6 +613,19 @@ newDFunName clas (ty:_) loc newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} +Make a name for the representation tycon of a data/newtype instance. It's an +*external* name, like otber top-level names, and hence must be made with +newGlobalBinder. + +\begin{code} +newFamInstTyConName :: Name -> SrcLoc -> TcM Name +newFamInstTyConName tc_name loc + = do { index <- nextDFunIndex + ; mod <- getModule + ; let occ = nameOccName tc_name + ; newGlobalBinder mod (mkInstTyTcOcc index occ) Nothing loc } +\end{code} + %************************************************************************ %* * diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c9dee4b..ce2846d 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -25,7 +25,8 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, + tcExtendGlobalEnv, tcExtendKindEnv, + tcExtendKindEnvTvs, newFamInstTyConName, tcExtendRecEnv, tcLookupTyVar, InstInfo ) import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) @@ -66,7 +67,8 @@ import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition, elemIndex ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, + srcSpanStart ) import ListSetOps ( equivClasses, minusList ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, @@ -327,7 +329,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt - ; index <- nextDFunIndex -- to generate unique names + ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon t_tvs)) @@ -335,11 +337,10 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - NewType -> - ASSERT( isSingleton data_cons ) - mkNewTyConRhs tc_name tycon (head data_cons) - ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax (Just (family, t_typats, index)) + NewType -> ASSERT( isSingleton data_cons ) + mkNewTyConRhs tc_name tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + False h98_syntax (Just (family, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 723a790..31cb19b 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -50,7 +50,6 @@ module TyCon( tyConArity, isClassTyCon, tyConClass_maybe, isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe, - tyConFamInstIndex, synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types @@ -275,9 +274,6 @@ data AlgTyConParent = -- An ordinary type constructor has no parent. TyCon -- a *coercion* identifying -- the representation type -- with the type instance - Int -- index to generate unique - -- name (needed here to put - -- into iface) data SynTyConRhs = OpenSynTyCon Kind -- Type family: *result* kind given @@ -817,25 +813,20 @@ tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas tyConClass_maybe ther_tycon = Nothing isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ _}) = True -isFamInstTyCon other_tycon = False +isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True +isFamInstTyCon other_tycon = False tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _ _}) = +tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = Just (fam, instTys) -tyConFamInst_maybe ther_tycon = +tyConFamInst_maybe ther_tycon = Nothing tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon -tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe _}) = +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = Just coe -tyConFamilyCoercion_maybe ther_tycon = +tyConFamilyCoercion_maybe ther_tycon = Nothing - -tyConFamInstIndex :: TyCon -> Int -tyConFamInstIndex (AlgTyCon {algTcParent = FamilyTyCon _ _ _ index}) = index -tyConFamInstIndex _ = - panic "tyConFamInstIndex" \end{code}