In interface files, store FastStrings rather than OccNames where possible

In all cases the namespace is known from the context, so this saves 1
byte per variable binding/occurrence (a few percent per iface file).

diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 3c1db55..0f65c8f 100644 (file)
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -33,11 +33,13 @@ import Name         ( Name, nameUnique, nameModule,
                          isWiredInName, mkIPName,
                          mkExternalName, mkInternalName )
 import NameSet         ( NameSet, emptyNameSet, addListToNameSet )
                          isWiredInName, mkIPName,
                          mkExternalName, mkInternalName )
 import NameSet         ( NameSet, emptyNameSet, addListToNameSet )

-import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv,
+import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS,

                          lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
 import PrelNames       ( gHC_PRIM, pREL_TUP )
 import Module          ( Module, emptyModuleEnv, 
                          lookupModuleEnv, extendModuleEnv_C )
                          lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
 import PrelNames       ( gHC_PRIM, pREL_TUP )
 import Module          ( Module, emptyModuleEnv, 
                          lookupModuleEnv, extendModuleEnv_C )

+import UniqFM           ( lookupUFM, addListToUFM )
+import FastString       ( FastString )

 import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
 import FiniteMap       ( emptyFM, lookupFM, addToFM )
 import BasicTypes      ( IPName(..), mapIPName )
 import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
 import FiniteMap       ( emptyFM, lookupFM, addToFM )
 import BasicTypes      ( IPName(..), mapIPName )

@@ -285,10 +287,10 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-tcIfaceLclId :: OccName -> IfL Id
+tcIfaceLclId :: FastString -> IfL Id

 tcIfaceLclId occ
   = do { lcl <- getLclEnv
 tcIfaceLclId occ
   = do { lcl <- getLclEnv

-       ; case (lookupOccEnv (if_id_env lcl) occ) of
+       ; case (lookupUFM (if_id_env lcl) occ) of

             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
         }
             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
         }

@@ -304,15 +306,15 @@ refineIfaceIdEnv (tv_subst, _) thing_inside
 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 extendIfaceIdEnv ids thing_inside
   = do { env <- getLclEnv
 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 extendIfaceIdEnv ids thing_inside
   = do { env <- getLclEnv

-       ; let { id_env' = extendOccEnvList (if_id_env env) pairs
-             ; pairs   = [(getOccName id, id) | id <- ids] }
+       ; let { id_env' = addListToUFM (if_id_env env) pairs
+             ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }

        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 
 
        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 
 

-tcIfaceTyVar :: OccName -> IfL TyVar
+tcIfaceTyVar :: FastString -> IfL TyVar

 tcIfaceTyVar occ
   = do { lcl <- getLclEnv
 tcIfaceTyVar occ
   = do { lcl <- getLclEnv

-       ; case (lookupOccEnv (if_tv_env lcl) occ) of
+       ; case (lookupUFM (if_tv_env lcl) occ) of

             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
         }
             Just ty_var -> return ty_var
             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
         }

@@ -320,8 +322,8 @@ tcIfaceTyVar occ
 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 extendIfaceTyVarEnv tyvars thing_inside
   = do { env <- getLclEnv
 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 extendIfaceTyVarEnv tyvars thing_inside
   = do { env <- getLclEnv

-       ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
-             ; pairs   = [(getOccName tv, tv) | tv <- tyvars] }
+       ; let { tv_env' = addListToUFM (if_tv_env env) pairs
+             ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }

        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 \end{code}
 
        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 \end{code}
 

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 2702181..4563714 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -56,9 +56,9 @@ import TyCon          ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCo
 import DataCon         ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
                          dataConTyCon, dataConIsInfix, isVanillaDataCon )
 import Class           ( FunDep, DefMeth, classExtraBigSig, classTyCon )
 import DataCon         ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
                          dataConTyCon, dataConIsInfix, isVanillaDataCon )
 import Class           ( FunDep, DefMeth, classExtraBigSig, classTyCon )

-import OccName         ( OccName, OccEnv, emptyOccEnv, 
-                         lookupOccEnv, extendOccEnv, parenSymOcc,
+import OccName         ( OccName, parenSymOcc, occNameFS,

                          OccSet, unionOccSets, unitOccSet )
                          OccSet, unionOccSets, unitOccSet )

+import UniqFM           ( UniqFM, emptyUFM, addToUFM, lookupUFM )

 import Name            ( Name, NamedThing(..), nameOccName, isExternalName )
 import CostCentre      ( CostCentre, pprCostCentreCore )
 import Literal         ( Literal )
 import Name            ( Name, NamedThing(..), nameOccName, isExternalName )
 import CostCentre      ( CostCentre, pprCostCentreCore )
 import Literal         ( Literal )

@@ -109,7 +109,7 @@ data IfaceDecl
   | IfaceClass { ifCtxt    :: IfaceContext,    -- Context...
                 ifName    :: OccName,          -- Name of the class
                 ifTyVars  :: [IfaceTvBndr],    -- Type variables
   | IfaceClass { ifCtxt    :: IfaceContext,    -- Context...
                 ifName    :: OccName,          -- Name of the class
                 ifTyVars  :: [IfaceTvBndr],    -- Type variables

-                ifFDs     :: [FunDep OccName], -- Functional dependencies
+                ifFDs     :: [FunDep FastString], -- Functional dependencies

                 ifSigs    :: [IfaceClassOp],   -- Method signatures
                 ifRec     :: RecFlag,          -- Is newtype/datatype associated with the class recursive?
                 ifVrcs    :: ArgVrcs           -- ... and what are its argument variances ...
                 ifSigs    :: [IfaceClassOp],   -- Method signatures
                 ifRec     :: RecFlag,          -- Is newtype/datatype associated with the class recursive?
                 ifVrcs    :: ArgVrcs           -- ... and what are its argument variances ...

@@ -201,13 +201,13 @@ data IfaceInfoItem
 
 --------------------------------
 data IfaceExpr
 
 --------------------------------
 data IfaceExpr

-  = IfaceLcl   OccName
+  = IfaceLcl   FastString

   | IfaceExt    IfaceExtName
   | IfaceType   IfaceType
   | IfaceTuple         Boxity [IfaceExpr]              -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr
   | IfaceExt    IfaceExtName
   | IfaceType   IfaceType
   | IfaceTuple         Boxity [IfaceExpr]              -- Saturated; type arguments omitted
   | IfaceLam   IfaceBndr IfaceExpr
   | IfaceApp   IfaceExpr IfaceExpr

-  | IfaceCase  IfaceExpr OccName IfaceType [IfaceAlt]
+  | IfaceCase  IfaceExpr FastString IfaceType [IfaceAlt]

   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceLit   Literal
   | IfaceLet   IfaceBinding  IfaceExpr
   | IfaceNote  IfaceNote IfaceExpr
   | IfaceLit   Literal

@@ -218,7 +218,7 @@ data IfaceNote = IfaceSCC CostCentre
               | IfaceInlineMe
                | IfaceCoreNote String
 
               | IfaceInlineMe
                | IfaceCoreNote String
 

-type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
+type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)

        -- Note: OccName, not IfaceBndr (and same with the case binder)
        -- We reconstruct the kind/type of the thing from the context
        -- thus saving bulk in interface files
        -- Note: OccName, not IfaceBndr (and same with the case binder)
        -- We reconstruct the kind/type of the thing from the context
        -- thus saving bulk in interface files

@@ -481,7 +481,7 @@ tyThingToIfaceDecl ext (AClass clas)
          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
          op_ty                = funResultTy rho_ty
 
          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
          op_ty                = funResultTy rho_ty
 

-    toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
+    toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2)

 
 tyThingToIfaceDecl ext (ATyCon tycon)
   | isSynTyCon tycon
 
 tyThingToIfaceDecl ext (ATyCon tycon)
   | isSynTyCon tycon

@@ -652,7 +652,7 @@ toIfaceExpr ext (Lit l)       = IfaceLit l
 toIfaceExpr ext (Type ty)     = IfaceType (toIfaceType ext ty)
 toIfaceExpr ext (Lam x b)     = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
 toIfaceExpr ext (App f a)     = toIfaceApp ext f [a]
 toIfaceExpr ext (Type ty)     = IfaceType (toIfaceType ext ty)
 toIfaceExpr ext (Lam x b)     = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
 toIfaceExpr ext (App f a)     = toIfaceApp ext f [a]

-toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
+toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as)

 toIfaceExpr ext (Let b e)     = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
 toIfaceExpr ext (Note n e)    = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
 
 toIfaceExpr ext (Let b e)     = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
 toIfaceExpr ext (Note n e)    = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
 

@@ -667,7 +667,7 @@ toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ex
 toIfaceBind ext (Rec prs)    = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
 
 ---------------------
 toIfaceBind ext (Rec prs)    = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
 
 ---------------------

-toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
+toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r)

 
 ---------------------
 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
 
 ---------------------
 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)

@@ -703,7 +703,7 @@ toIfaceVar ext v
   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
          -- Foreign calls have special syntax
   | isExternalName name                    = IfaceExt (ext name)
   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
          -- Foreign calls have special syntax
   | isExternalName name                    = IfaceExt (ext name)

-  | otherwise                      = IfaceLcl (nameOccName name)
+  | otherwise                      = IfaceLcl (occNameFS (nameOccName name))

   where
     name = idName v
 \end{code}
   where
     name = idName v
 \end{code}

@@ -949,24 +949,24 @@ eqIfTc _ _ = NotEqual
 
 \begin{code}
 ------------------------------------
 
 \begin{code}
 ------------------------------------

-type EqEnv = OccEnv OccName    -- Tracks the mapping from L-variables to R-variables
+type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables

 
 

-eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
-eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
+eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
+eqIfOcc env n1 n2 = case lookupUFM env n1 of

                        Just n1 -> bool (n1 == n2)
                        Nothing -> bool (n1 == n2)
 
                        Just n1 -> bool (n1 == n2)
                        Nothing -> bool (n1 == n2)
 

-extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
+extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv

 extendEqEnv env n1 n2 | n1 == n2  = env
 extendEqEnv env n1 n2 | n1 == n2  = env

-                     | otherwise = extendOccEnv env n1 n2
+                     | otherwise = addToUFM env n1 n2

 
 emptyEqEnv :: EqEnv
 
 emptyEqEnv :: EqEnv

-emptyEqEnv = emptyOccEnv
+emptyEqEnv = emptyUFM

 
 ------------------------------------
 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 
 
 ------------------------------------
 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 

-eq_ifNakedBndr :: ExtEnv OccName
+eq_ifNakedBndr :: ExtEnv FastString

 eq_ifBndr      :: ExtEnv IfaceBndr
 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 eq_ifBndr      :: ExtEnv IfaceBndr
 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 eq_ifIdBndr    :: ExtEnv IfaceIdBndr

@@ -983,7 +983,7 @@ eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env
 eq_ifBndrs     :: ExtEnv [IfaceBndr]
 eq_ifIdBndrs   :: ExtEnv [IfaceIdBndr]
 eq_ifTvBndrs   :: ExtEnv [IfaceTvBndr]
 eq_ifBndrs     :: ExtEnv [IfaceBndr]
 eq_ifIdBndrs   :: ExtEnv [IfaceIdBndr]
 eq_ifTvBndrs   :: ExtEnv [IfaceTvBndr]

-eq_ifNakedBndrs :: ExtEnv [OccName]
+eq_ifNakedBndrs :: ExtEnv [FastString]

 eq_ifBndrs     = eq_bndrs_with eq_ifBndr
 eq_ifIdBndrs   = eq_bndrs_with eq_ifIdBndr
 eq_ifTvBndrs   = eq_bndrs_with eq_ifTvBndr
 eq_ifBndrs     = eq_bndrs_with eq_ifBndr
 eq_ifIdBndrs   = eq_bndrs_with eq_ifIdBndr
 eq_ifTvBndrs   = eq_bndrs_with eq_ifTvBndr

diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 76438dd..bf0f383 100644 (file)
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -31,7 +31,7 @@ import TypeRep                ( TyThing(..), Type(..), PredType(..), ThetaType )
 import TyCon           ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
 import Var             ( isId, tyVarKind, idType )
 import TysWiredIn      ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
 import TyCon           ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
 import Var             ( isId, tyVarKind, idType )
 import TysWiredIn      ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )

-import OccName         ( OccName, parenSymOcc )
+import OccName         ( OccName, parenSymOcc, occNameFS )

 import Name            ( Name, getName, getOccName, nameModule, nameOccName,
                          wiredInNameTyThing_maybe )
 import Module          ( Module )
 import Name            ( Name, getName, getOccName, nameModule, nameOccName,
                          wiredInNameTyThing_maybe )
 import Module          ( Module )

@@ -98,17 +98,17 @@ interactiveExtNameFun print_unqual name
 
 \begin{code}
 data IfaceBndr                 -- Local (non-top-level) binders
 
 \begin{code}
 data IfaceBndr                 -- Local (non-top-level) binders

-  = IfaceIdBndr IfaceIdBndr
-  | IfaceTvBndr IfaceTvBndr
+  = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
+  | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr

 
 

-type IfaceIdBndr  = (OccName, IfaceType)       -- OccName, because always local
-type IfaceTvBndr  = (OccName, IfaceKind)
+type IfaceIdBndr  = (FastString, IfaceType)
+type IfaceTvBndr  = (FastString, IfaceKind)

 
 -------------------------------
 type IfaceKind = Kind                  -- Re-use the Kind type, but no KindVars in it
 
 data IfaceType
 
 -------------------------------
 type IfaceKind = Kind                  -- Re-use the Kind type, but no KindVars in it
 
 data IfaceType

-  = IfaceTyVar    OccName                      -- Type variable only, not tycon
+  = IfaceTyVar    FastString                   -- Type variable only, not tycon

   | IfaceAppTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType
   | IfaceAppTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType

@@ -327,8 +327,8 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
 
 \begin{code}
 ----------------
 
 \begin{code}
 ----------------

-toIfaceTvBndr tyvar   = (getOccName tyvar, tyVarKind tyvar)
-toIfaceIdBndr ext id  = (getOccName id,    toIfaceType ext (idType id))
+toIfaceTvBndr tyvar   = (occNameFS (getOccName tyvar), tyVarKind tyvar)
+toIfaceIdBndr ext id  = (occNameFS (getOccName id),    toIfaceType ext (idType id))

 toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
 
 toIfaceBndr ext var
 toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
 
 toIfaceBndr ext var

@@ -338,7 +338,7 @@ toIfaceBndr ext var
 ---------------------
 toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
 -- Synonyms are retained in the interface type
 ---------------------
 toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
 -- Synonyms are retained in the interface type

-toIfaceType ext (TyVarTy tv)                = IfaceTyVar (getOccName tv)
+toIfaceType ext (TyVarTy tv)                = IfaceTyVar (occNameFS (getOccName tv))

 toIfaceType ext (AppTy t1 t2)               = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
 toIfaceType ext (FunTy t1 t2)               = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
 toIfaceType ext (TyConApp tc tys)           = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys)
 toIfaceType ext (AppTy t1 t2)               = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
 toIfaceType ext (FunTy t1 t2)               = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
 toIfaceType ext (TyConApp tc tys)           = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys)

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 7c4c535..0b4df33 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -51,14 +51,15 @@ import Var          ( TyVar, mkTyVar, tyVarKind )
 import Name            ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
                          wiredInNameTyThing_maybe, nameParent )
 import NameEnv
 import Name            ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
                          wiredInNameTyThing_maybe, nameParent )
 import NameEnv

-import OccName         ( OccName )
+import OccName         ( OccName, mkVarOccFS, mkTyVarOcc )
+import FastString       ( FastString )

 import Module          ( Module, lookupModuleEnv )
 import UniqSupply      ( initUs_ )
 import Outputable      
 import ErrUtils                ( Message )
 import Maybes          ( MaybeErr(..) )
 import SrcLoc          ( noSrcLoc )
 import Module          ( Module, lookupModuleEnv )
 import UniqSupply      ( initUs_ )
 import Outputable      
 import ErrUtils                ( Message )
 import Maybes          ( MaybeErr(..) )
 import SrcLoc          ( noSrcLoc )

-import Util            ( zipWithEqual, dropList, equalLength )
+import Util            ( zipWithEqual, equalLength, splitAtList )

 import DynFlags                ( DynFlag(..), isOneShot )
 \end{code}
 
 import DynFlags                ( DynFlag(..), isOneShot )
 \end{code}
 

@@ -603,7 +604,7 @@ tcIfaceExpr (IfaceApp fun arg)
 
 tcIfaceExpr (IfaceCase scrut case_bndr ty alts) 
   = tcIfaceExpr scrut          `thenM` \ scrut' ->
 
 tcIfaceExpr (IfaceCase scrut case_bndr ty alts) 
   = tcIfaceExpr scrut          `thenM` \ scrut' ->

-    newIfaceName case_bndr     `thenM` \ case_bndr_name ->
+    newIfaceName (mkVarOccFS case_bndr)        `thenM` \ case_bndr_name ->

     let
        scrut_ty   = exprType scrut'
        case_bndr' = mkLocalId case_bndr_name scrut_ty
     let
        scrut_ty   = exprType scrut'
        case_bndr' = mkLocalId case_bndr_name scrut_ty

@@ -657,23 +658,24 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
 -- A case alternative is made quite a bit more complicated
 -- by the fact that we omit type annotations because we can
 -- work them out.  True enough, but its not that easy!
 -- A case alternative is made quite a bit more complicated
 -- by the fact that we omit type annotations because we can
 -- work them out.  True enough, but its not that easy!

-tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
+tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)

   = do { let tycon_mod = nameModule (tyConName tycon)
        ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
        ; ASSERT2( con `elem` tyConDataCons tycon,
                   ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
                  
          if isVanillaDataCon con then
   = do { let tycon_mod = nameModule (tyConName tycon)
        ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
        ; ASSERT2( con `elem` tyConDataCons tycon,
                   ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
                  
          if isVanillaDataCon con then

-               tcVanillaAlt con inst_tys arg_occs rhs
+               tcVanillaAlt con inst_tys arg_strs rhs

          else
     do         {       -- General case
          else
     do         {       -- General case

-         arg_names <- newIfaceNames arg_occs
+          let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs
+        ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs
+        ; id_names    <- mapM (newIfaceName . mkVarOccFS) id_strs

        ; let   tyvars   = [ mkTyVar name (tyVarKind tv) 
        ; let   tyvars   = [ mkTyVar name (tyVarKind tv) 

-                          | (name,tv) <- arg_names `zip` dataConTyVars con] 
+                          | (name,tv) <- tyvar_names `zip` dataConTyVars con ]

                arg_tys  = dataConInstArgTys con (mkTyVarTys tyvars)
                arg_tys  = dataConInstArgTys con (mkTyVarTys tyvars)

-               id_names = dropList tyvars arg_names

                arg_ids  = ASSERT2( equalLength id_names arg_tys,
                arg_ids  = ASSERT2( equalLength id_names arg_tys,

-                                   ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
+                                   ppr (con, tyvar_names++id_names, rhs) $$ ppr tyvars $$ ppr arg_tys )

                           zipWith mkLocalId id_names arg_tys
 
                Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys)
                           zipWith mkLocalId id_names arg_tys
 
                Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys)

@@ -694,11 +696,11 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
     do { let [data_con] = tyConDataCons tycon
        ; tcVanillaAlt data_con inst_tys arg_occs rhs }
 
     do { let [data_con] = tyConDataCons tycon
        ; tcVanillaAlt data_con inst_tys arg_occs rhs }
 

-tcVanillaAlt data_con inst_tys arg_occs rhs
-  = do { arg_names <- newIfaceNames arg_occs
+tcVanillaAlt data_con inst_tys arg_strs rhs
+  = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs)

        ; let arg_tys = dataConInstArgTys data_con inst_tys
        ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
        ; let arg_tys = dataConInstArgTys data_con inst_tys
        ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,

-                                ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
+                                ppr data_con <+> ppr inst_tys <+> ppr arg_strs $$ ppr rhs )

                        zipWith mkLocalId arg_names arg_tys
        ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
        ; returnM (DataAlt data_con, arg_ids, rhs') }
                        zipWith mkLocalId arg_names arg_tys
        ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
        ; returnM (DataAlt data_con, arg_ids, rhs') }

@@ -931,16 +933,16 @@ bindIfaceBndrs (b:bs) thing_inside
     thing_inside (b':bs')
 
 -----------------------
     thing_inside (b':bs')
 
 -----------------------

-bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
+bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a

 bindIfaceId (occ, ty) thing_inside
 bindIfaceId (occ, ty) thing_inside

-  = do { name <- newIfaceName occ
+  = do { name <- newIfaceName (mkVarOccFS occ)

        ; ty' <- tcIfaceType ty
        ; let { id = mkLocalId name ty' }
        ; extendIfaceIdEnv [id] (thing_inside id) }
     
        ; ty' <- tcIfaceType ty
        ; let { id = mkLocalId name ty' }
        ; extendIfaceIdEnv [id] (thing_inside id) }
     

-bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a

 bindIfaceIds bndrs thing_inside
 bindIfaceIds bndrs thing_inside

-  = do         { names <- newIfaceNames occs
+  = do         { names <- newIfaceNames (map mkVarOccFS occs)

        ; tys' <- mappM tcIfaceType tys
        ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
        ; extendIfaceIdEnv ids (thing_inside ids) }
        ; tys' <- mappM tcIfaceType tys
        ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
        ; extendIfaceIdEnv ids (thing_inside ids) }

@@ -949,23 +951,23 @@ bindIfaceIds bndrs thing_inside
 
 
 -----------------------
 
 
 -----------------------

-newExtCoreBndr :: (OccName, IfaceType) -> IfL Id
-newExtCoreBndr (occ, ty)
+newExtCoreBndr :: IfaceIdBndr -> IfL Id
+newExtCoreBndr (var, ty)

   = do { mod <- getIfModule
   = do { mod <- getIfModule

-       ; name <- newGlobalBinder mod occ Nothing noSrcLoc
+       ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc

        ; ty' <- tcIfaceType ty
        ; return (mkLocalId name ty') }
 
 -----------------------
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside
        ; ty' <- tcIfaceType ty
        ; return (mkLocalId name ty') }
 
 -----------------------
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside

-  = do { name <- newIfaceName occ
+  = do { name <- newIfaceName (mkTyVarOcc occ)

        ; let tyvar = mk_iface_tyvar name kind
        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 bindIfaceTyVars bndrs thing_inside
        ; let tyvar = mk_iface_tyvar name kind
        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 bindIfaceTyVars bndrs thing_inside

-  = do { names <- newIfaceNames occs
+  = do { names <- newIfaceNames (map mkTyVarOcc occs)

        ; let tyvars = zipWith mk_iface_tyvar names kinds
        ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
   where
        ; let tyvars = zipWith mk_iface_tyvar names kinds
        ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
   where

diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 4d2fc70..02a6c7b 100644 (file)
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -168,7 +168,7 @@ vdef        :: { (IfaceIdBndr, IfaceExpr) }
   -- same as the module being compiled, and Iface syntax only
   -- has OccNames in binding positions
 
   -- same as the module being compiled, and Iface syntax only
   -- has OccNames in binding positions
 

-qd_occ :: { OccName }
+qd_occ :: { FastString }

         : var_occ { $1 }
         | d_occ   { $1 }
 
         : var_occ { $1 }
         | d_occ   { $1 }
 

@@ -212,7 +212,7 @@ kind        :: { IfaceKind }
 
 aexp    :: { IfaceExpr }
        : var_occ                { IfaceLcl $1 }
 
 aexp    :: { IfaceExpr }
        : var_occ                { IfaceLcl $1 }

-       | modid '.' qd_occ       { IfaceExt (ExtPkg $1 $3) }
+        | modid '.' qd_occ      { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) }

        | lit           { IfaceLit $1 }
        | '(' exp ')'   { $2 }
 
        | lit           { IfaceLit $1 }
        | '(' exp ')'   { $2 }
 

@@ -260,11 +260,11 @@ lit       :: { Literal }
        | '(' CHAR '::' aty ')'         { MachChar $2 }
        | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 
        | '(' CHAR '::' aty ')'         { MachChar $2 }
        | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 

-tv_occ :: { OccName }
-       : NAME  { mkOccName tvName $1 }
+tv_occ :: { FastString }
+       : NAME  { mkFastString $1 }

 
 

-var_occ        :: { OccName }
-       : NAME  { mkVarOcc $1 }
+var_occ        :: { FastString }
+       : NAME  { mkFastString $1 }

 
 
 -- Type constructor
 
 
 -- Type constructor

@@ -278,8 +278,8 @@ d_pat_occ :: { OccName }
 
 -- Data constructor occurrence in an expression;
 -- use the varName because that's the worker Id
 
 -- Data constructor occurrence in an expression;
 -- use the varName because that's the worker Id

-d_occ :: { OccName }
-       : CNAME { mkVarOcc $1 }
+d_occ :: { FastString }
+       : CNAME { mkFastString $1 }

 
 {
 
 
 {
 

@@ -314,14 +314,14 @@ eqTc (IfaceTc (ExtPkg mod occ)) tycon
 -- are very limited (see the productions for 'ty', so the translation
 -- isn't hard
 toHsType :: IfaceType -> LHsType RdrName
 -- are very limited (see the productions for 'ty', so the translation
 -- isn't hard
 toHsType :: IfaceType -> LHsType RdrName

-toHsType (IfaceTyVar v)                         = noLoc $ HsTyVar (mkRdrUnqual v)
+toHsType (IfaceTyVar v)                         = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOcc v))

 toHsType (IfaceAppTy t1 t2)                     = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
 toHsType (IfaceFunTy t1 t2)                     = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
 toHsType (IfaceAppTy t1 t2)                     = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
 toHsType (IfaceFunTy t1 t2)                     = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
 toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) 
 toHsType (IfaceForAllTy tv t)            = add_forall (toHsTvBndr tv) (toHsType t)
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName

-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) k

 
 ifaceExtRdrName :: IfaceExtName -> RdrName
 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
 
 ifaceExtRdrName :: IfaceExtName -> RdrName
 ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f16e9a8..4ad1b0d 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -59,13 +59,13 @@ import RdrName              ( GlobalRdrEnv, LocalRdrEnv )
 import Name            ( Name )
 import NameEnv
 import NameSet         ( NameSet, unionNameSets, DefUses )
 import Name            ( Name )
 import NameEnv
 import NameSet         ( NameSet, unionNameSets, DefUses )

-import OccName         ( OccEnv )

 import Var             ( Id, TyVar )
 import VarEnv          ( TidyEnv )
 import Module
 import SrcLoc          ( SrcSpan, SrcLoc, Located, srcSpanStart )
 import VarSet          ( IdSet )
 import ErrUtils                ( Messages, Message )
 import Var             ( Id, TyVar )
 import VarEnv          ( TidyEnv )
 import Module
 import SrcLoc          ( SrcSpan, SrcLoc, Located, srcSpanStart )
 import VarSet          ( IdSet )
 import ErrUtils                ( Messages, Message )

+import UniqFM           ( UniqFM )

 import UniqSupply      ( UniqSupply )
 import BasicTypes      ( IPName )
 import Util            ( thenCmp )
 import UniqSupply      ( UniqSupply )
 import BasicTypes      ( IPName )
 import Util            ( thenCmp )

@@ -266,8 +266,8 @@ data IfLclEnv
                --      .hi file, or GHCi state, or ext core
                -- plus which bit is currently being examined
 
                --      .hi file, or GHCi state, or ext core
                -- plus which bit is currently being examined
 

-       if_tv_env  :: OccEnv TyVar,     -- Nested tyvar bindings
-       if_id_env  :: OccEnv Id         -- Nested id binding
+       if_tv_env  :: UniqFM TyVar,     -- Nested tyvar bindings
+       if_id_env  :: UniqFM Id         -- Nested id binding

     }
 \end{code}
 
     }
 \end{code}