X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=acf518f9d3e6052731a8476690a92743c08d43a8;hb=b749b2c7fd7fb9cdd464c213672ded760f498dc9;hp=6993cec2f740abb2a983a1711598f0e9d1210aab;hpb=e2505cabd45cb180e73b9d55a225cd1717c483b3;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 6993cec..acf518f 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -10,37 +10,35 @@ module Name (
 
 	-- The Name type
 	Name,					-- Abstract
-	mkInternalName, mkSystemName, mkFCallName,
+	mkInternalName, mkSystemName, 
+	mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName,
 	mkIPName,
 	mkExternalName, mkKnownKeyExternalName, mkWiredInName,
 
 	nameUnique, setNameUnique,
 	nameOccName, nameModule, nameModule_maybe,
-	setNameOcc, nameRdrName, setNameModuleAndLoc, 
-	toRdrName, hashName, 
-	externaliseName, localiseName,
+	setNameOcc, setNameSrcLoc, 
+	hashName, externaliseName, localiseName,
 
-	nameSrcLoc, 
+	nameSrcLoc, eqNameByOcc,
 
 	isSystemName, isInternalName, isExternalName,
-	isTyVarName, isDllName, 
+	isTyVarName, isDllName, isWiredInName,
 	nameIsLocalOrFrom, isHomePackageName,
 	
 	-- Class NamedThing and overloaded friends
 	NamedThing(..),
-	getSrcLoc, getOccString, toRdrName
+	getSrcLoc, getOccString
     ) where
 
 #include "HsVersions.h"
 
 import OccName		-- All of it
-import Module		( Module, moduleName, mkVanillaModule, isHomeModule )
-import RdrName		( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
+import Module		( Module, moduleName, isHomeModule )
 import CmdLineOpts	( opt_Static )
-import SrcLoc		( builtinSrcLoc, noSrcLoc, SrcLoc )
+import SrcLoc		( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc )
 import Unique		( Unique, Uniquable(..), getKey, pprUnique )
 import FastTypes
-import Binary
 import Outputable
 \end{code}
 
@@ -107,12 +105,6 @@ nameSrcLoc		:: Name -> SrcLoc
 nameUnique  name = n_uniq name
 nameOccName name = n_occ  name
 nameSrcLoc  name = n_loc  name
-
-nameModule (Name { n_sort = External mod }) = mod
-nameModule name				  = pprPanic "nameModule" (ppr name)
-
-nameModule_maybe (Name { n_sort = External mod }) = Just mod
-nameModule_maybe name				= Nothing
 \end{code}
 
 \begin{code}
@@ -121,9 +113,18 @@ isInternalName	  :: Name -> Bool
 isExternalName	  :: Name -> Bool
 isSystemName	  :: Name -> Bool
 isHomePackageName :: Name -> Bool
+isWiredInName	  :: Name -> Bool
+
+isWiredInName name = isWiredInLoc (n_loc name)
 
 isExternalName (Name {n_sort = External _}) = True
-isExternalName other	                = False
+isExternalName other	                    = False
+
+nameModule (Name { n_sort = External mod }) = mod
+nameModule name				    = pprPanic "nameModule" (ppr name)
+
+nameModule_maybe (Name { n_sort = External mod }) = Just mod
+nameModule_maybe name				  = Nothing
 
 isInternalName name = not (isExternalName name)
 
@@ -141,6 +142,18 @@ isTyVarName name = isTvOcc (nameOccName name)
 
 isSystemName (Name {n_sort = System}) = True
 isSystemName other		      = False
+
+eqNameByOcc :: Name -> Name -> Bool
+-- Compare using the strings, not the unique
+-- See notes with HsCore.eq_ufVar
+eqNameByOcc (Name {n_sort = sort1, n_occ = occ1})
+	    (Name {n_sort = sort2, n_occ = occ2})
+  = sort1 `eq_sort` sort2 && occ1 == occ2
+  where
+    eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2
+    eq_sort (External _)  _		= False
+    eq_sort _            (External _)   = False
+    eq_sort _		 _		= True
 \end{code}
 
 
@@ -164,20 +177,30 @@ mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = o
 
 mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name
 mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod,
-				       n_occ = occ, n_loc = loc }
+				         n_occ = occ, n_loc = loc }
 
-mkKnownKeyExternalName :: RdrName -> Unique -> Name
-mkKnownKeyExternalName rdr_name uniq
-  = mkExternalName uniq (mkVanillaModule (rdrNameModule rdr_name))
-		      (rdrNameOcc rdr_name)
-		      builtinSrcLoc
+mkKnownKeyExternalName :: Module -> OccName -> Unique -> Name
+mkKnownKeyExternalName mod occ uniq
+  = mkExternalName uniq mod occ noSrcLoc
 
 mkWiredInName :: Module -> OccName -> Unique -> Name
-mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc
+mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc
 
-mkSystemName :: Unique -> EncodedFS -> Name
+mkSystemName :: Unique -> UserFS -> Name
 mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, 
-				n_occ = mkVarOcc fs, n_loc = noSrcLoc }
+			      n_occ = mkVarOcc fs, n_loc = noSrcLoc }
+
+-- Use this version when the string is already encoded.  Avoids duplicating
+-- the string each time a new name is created.
+mkSystemNameEncoded :: Unique -> EncodedFS -> Name
+mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, 
+			             n_occ = mkSysOccFS varName fs, 
+				     n_loc = noSrcLoc }
+
+mkSystemTvNameEncoded :: Unique -> EncodedFS -> Name
+mkSystemTvNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, 
+			               n_occ = mkSysOccFS tvName fs, 
+				       n_loc = noSrcLoc }
 
 mkFCallName :: Unique -> EncodedString -> Name
 	-- The encoded string completely describes the ccall
@@ -207,10 +230,8 @@ externaliseName n mod = n { n_sort = External mod }
 localiseName :: Name -> Name
 localiseName n = n { n_sort = Internal }
 				
-setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name
-setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc}
-		       where
-			 set (External _) = External mod
+setNameSrcLoc :: Name -> SrcLoc -> Name
+setNameSrcLoc name loc = name {n_loc = loc}
 \end{code}
 
 
@@ -223,13 +244,6 @@ setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc
 \begin{code}
 hashName :: Name -> Int
 hashName name = iBox (getKey (nameUnique name))
-
-
-nameRdrName :: Name -> RdrName
--- Makes a qualified name for top-level (External) names, 
--- whether locally defined or not and an unqualified name just for Internals
-nameRdrName (Name { n_occ = occ, n_sort = External mod }) = mkRdrOrig (moduleName mod) occ
-nameRdrName (Name { n_occ = occ })			  = mkRdrUnqual occ
 \end{code}
 
 
@@ -262,26 +276,6 @@ instance NamedThing Name where
     getName n = n
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection{Binary output}
-%*									*
-%************************************************************************
-
-\begin{code}
-instance Binary Name where
-  -- we must print these as RdrNames, because that's how they will be read in
-  put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} =
-   case sort of
-    External mod
-	| this_mod == mod -> put_ bh (mkRdrUnqual occ)
-	| otherwise       -> put_ bh (mkRdrOrig (moduleName mod) occ)
-        where (this_mod,_,_,_) = getUserData bh
-    _ -> do 
-	put_ bh (mkRdrUnqual occ)
-
-  get bh = error "can't Binary.get a Name"    
-\end{code}
 
 %************************************************************************
 %*									*
@@ -294,6 +288,9 @@ instance Outputable Name where
 	-- When printing interfaces, all Internals have been given nice print-names
     ppr name = pprName name
 
+instance OutputableBndr Name where
+    pprBndr _ name = pprName name
+
 pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
   = getPprStyle $ \ sty ->
     case sort of
@@ -303,17 +300,13 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
 
 pprExternal sty name uniq mod occ
   | codeStyle sty        = ppr (moduleName mod) <> char '_' <> pprOccName occ
-
-  | debugStyle sty       = ppr (moduleName mod) <> dot <> pprOccName occ <> 
-			    text "{-" <> pprUnique uniq <> text "-}"
-
+  | debugStyle sty       = ppr (moduleName mod) <> dot <> ppr_debug_occ uniq occ
   | unqualStyle sty name = pprOccName occ
   | otherwise		 = ppr (moduleName mod) <> dot <> pprOccName occ
 
 pprInternal sty uniq occ
   | codeStyle sty  = pprUnique uniq
-  | debugStyle sty = pprOccName occ <> 
-		     text "{-" <> pprUnique uniq <> text "-}"
+  | debugStyle sty = ppr_debug_occ uniq occ
   | otherwise      = pprOccName occ	-- User style
 
 -- Like Internal, except that we only omit the unique in Iface style
@@ -323,6 +316,10 @@ pprSystem sty uniq occ
 				-- If the tidy phase hasn't run, the OccName
 				-- is unlikely to be informative (like 's'),
 				-- so print the unique
+
+ppr_debug_occ uniq occ = hsep [pprOccName occ, text "{-", 
+			       text (briefOccNameFlavour occ), 
+			       pprUnique uniq, text "-}"]
 \end{code}
 
 %************************************************************************
@@ -342,10 +339,8 @@ class NamedThing a where
 \begin{code}
 getSrcLoc	    :: NamedThing a => a -> SrcLoc
 getOccString	    :: NamedThing a => a -> String
-toRdrName	    :: NamedThing a => a -> RdrName
 
 getSrcLoc	    = nameSrcLoc	   . getName
 getOccString 	    = occNameString	   . getOccName
-toRdrName	    = nameRdrName	   . getName
 \end{code}