Get of fam inst index in ifaces
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 18:48:02 +0000 (18:48 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 20 Sep 2006 18:48:02 +0000 (18:48 +0000)
Mon Sep 18 19:40:42 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Get of fam inst index in ifaces
  Fri Sep  8 16:31:26 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * 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!          ***

compiler/basicTypes/OccName.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/TyCon.lhs

index 9319c67..1440525 100644 (file)
@@ -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}
index 8093c08..6384ddc 100644 (file)
@@ -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
         }
     
 
index 5f9c1d8..bf62095 100644 (file)
@@ -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) &&&
index 21332fa..ba72c25 100644 (file)
@@ -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}
 
 
index 3bc9257..2069f89 100644 (file)
@@ -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
index 68abd23..6c197cc 100644 (file)
@@ -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
index 1d093e2..7828394 100644 (file)
@@ -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}
+
 
 %************************************************************************
 %*                                                                     *
index c9dee4b..ce2846d 100644 (file)
@@ -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
index 723a790..31cb19b 100644 (file)
@@ -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}