X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=c47d4802d7a4293d4cf6c686233810a971d079aa;hb=13a428caa18deb2805e307cbe7a99fa9f09c13a4;hp=c809a493dae4756bdd4574ab786455c53a766118;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c809a49..c47d480 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -1,142 +1,240 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -#include "HsVersions.h" - module Name ( - -- things for the Name NON-abstract type - Name(..), - - isTyConName, isClassName, isClassOpName, - isUnboundName, invisibleName, - - getTagFromClassOpName, getSynNameArity, - - getNameShortName, getNameFullName - + -- Re-export the OccName stuff + module OccName, + + -- The Name type + Name, -- Abstract + mkLocalName, mkSysLocalName, mkFCallName, + mkIPName, + mkGlobalName, mkKnownKeyGlobal, mkWiredInName, + + nameUnique, setNameUnique, + nameOccName, nameModule, nameModule_maybe, + setNameOcc, nameRdrName, setNameModuleAndLoc, + toRdrName, hashName, + globaliseName, localiseName, + + nameSrcLoc, + + isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + isTyVarName, isDllName, + nameIsLocalOrFrom, isHomePackageName, + + -- Class NamedThing and overloaded friends + NamedThing(..), + getSrcLoc, getOccString, toRdrName ) where -import Ubiq{-uitous-} - -import NameLoop -- break Name/Id loop, Name/PprType/Id loop +#include "HsVersions.h" -import NameTypes -import Outputable ( ExportFlag(..) ) -import Pretty -import PprStyle ( PprStyle(..) ) -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import TyCon ( TyCon, synTyConArity ) -import TyVar ( GenTyVar ) -import Unique ( pprUnique, Unique ) -import Util ( panic, panic#, pprPanic ) +import OccName -- All of it +import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) +import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import CmdLineOpts ( opt_Static ) +import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), u2i, pprUnique ) +import FastTypes +import Outputable \end{code} %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ - + \begin{code} -data Name - = Short Unique -- Local ids and type variables - ShortName - - -- Nano-prelude things; truly wired in. - -- Includes all type constructors and their associated data constructors - | WiredInTyCon TyCon - | WiredInVal Id - - | TyConName Unique -- TyCons other than Prelude ones; need to - FullName -- separate these because we want to pin on - Arity -- their arity. - Bool -- False <=> `type', - -- True <=> `data' or `newtype' - [Name] -- List of user-visible data constructors; - -- NB: for `data' types only. - -- Used in checking import/export lists. - - | ClassName Unique - FullName - [Name] -- List of class methods; used for checking - -- import/export lists. - - | ValName Unique -- Top level id - FullName - - | ClassOpName Unique - Name -- Name associated w/ the defined class - -- (can get unique and export info, etc., from this) - FAST_STRING -- The class operation - Int -- Unique tag within the class - - -- Miscellaneous - | Unbound FAST_STRING -- Placeholder for a name which isn't in scope - -- Used only so that the renamer can carry on after - -- finding an unbound identifier. - -- The string is grabbed from the unbound name, for - -- debugging information only. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: Unique, + n_loc :: !SrcLoc -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +data NameSort + = Global Module -- (a) TyCon, Class, their derived Ids, dfun Id + -- (b) Imported Id + -- (c) Top-level Id in the original source, even if + -- locally defined + + | Local -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') \end{code} -These @is..@ functions are used in the renamer to check that (eg) a tycon -is seen in a context which demands one. +Notes about the NameSorts: -\begin{code} -isTyConName, isClassName, isUnboundName :: Name -> Bool +1. Initially, top-level Ids (including locally-defined ones) get Global names, + and all other local Ids get Local names -isTyConName (TyConName _ _ _ _ _) = True -isTyConName (WiredInTyCon _) = True -isTyConName other = False +2. Things with a @Global@ name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @Global@ first. -isClassName (ClassName _ _ _) = True -isClassName other = False +3. In the tidy-core phase, a Global that is not visible to an importer + is changed to Local, and a Local that is visible is changed to Global -isUnboundName (Unbound _) = True -isUnboundName other = False -\end{code} +4. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible -@isClassOpName@ is a little cleverer: it checks to see whether the -class op comes from the correct class. + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. \begin{code} -isClassOpName :: Name -- The name of the class expected for this op - -> Name -- The name of the thing which should be a class op - -> Bool +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc -isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _) - = uniq1 == uniq2 -isClassOpName other_class other_op = False +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameSrcLoc name = n_loc name + +nameModule (Name { n_sort = Global mod }) = mod +nameModule name = pprPanic "nameModule" (ppr name) + +nameModule_maybe (Name { n_sort = Global mod }) = Just mod +nameModule_maybe name = Nothing \end{code} -A Name is ``invisible'' if the user has no business seeing it; e.g., a -data-constructor for an abstract data type (but whose constructors are -known because of a pragma). \begin{code} -invisibleName :: Name -> Bool +nameIsLocalOrFrom :: Module -> Name -> Bool +isLocalName :: Name -> Bool -- Not globals +isGlobalName :: Name -> Bool +isSystemName :: Name -> Bool +isExternallyVisibleName :: Name -> Bool +isHomePackageName :: Name -> Bool + +isGlobalName (Name {n_sort = Global _}) = True +isGlobalName other = False + +isLocalName name = not (isGlobalName name) + +nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from +nameIsLocalOrFrom from other = True + +isHomePackageName (Name {n_sort = Global mod}) = isHomeModule mod +isHomePackageName other = True -- Local and system names + +isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && not (isHomePackageName nm) + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +-- Global names are by definition those that are visible +-- outside the module, *as seen by the linker*. Externally visible +-- does not mean visible at the source level +isExternallyVisibleName name = isGlobalName name + +isSystemName (Name {n_sort = System}) = True +isSystemName other = False +\end{code} + + +%************************************************************************ +%* * +\subsection{Making names} +%* * +%************************************************************************ -invisibleName (TyConName _ n _ _ _) = invisibleFullName n -invisibleName (ClassName _ n _) = invisibleFullName n -invisibleName (ValName _ n) = invisibleFullName n -invisibleName _ = False +\begin{code} +mkLocalName :: Unique -> OccName -> SrcLoc -> Name +mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which puts the uniques + -- into the print name (see setNameVisibility below) + +mkGlobalName :: Unique -> Module -> OccName -> SrcLoc -> Name +mkGlobalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = Global mod, + n_occ = occ, n_loc = loc } + +mkKnownKeyGlobal :: RdrName -> Unique -> Name +mkKnownKeyGlobal rdr_name uniq + = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) + builtinSrcLoc + +mkWiredInName :: Module -> OccName -> Unique -> Name +mkWiredInName mod occ uniq = mkGlobalName uniq mod occ builtinSrcLoc + +mkSysLocalName :: Unique -> UserFS -> Name +mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkVarOcc fs, n_loc = noSrcLoc } + +mkFCallName :: Unique -> EncodedString -> Name + -- The encoded string completely describes the ccall +mkFCallName uniq str = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkFCallOcc str, n_loc = noSrcLoc } + +mkIPName :: Unique -> OccName -> Name +mkIPName uniq occ + = Name { n_uniq = uniq, + n_sort = Local, + n_occ = occ, + n_loc = noSrcLoc } \end{code} \begin{code} -getTagFromClassOpName :: Name -> Int -getTagFromClassOpName (ClassOpName _ _ _ tag) = tag +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique name uniq = name {n_uniq = uniq} + +setNameOcc :: Name -> OccName -> Name +setNameOcc name occ = name {n_occ = occ} + +globaliseName :: Name -> Module -> Name +globaliseName n mod = n { n_sort = Global mod } + +localiseName :: Name -> Name +localiseName n = n { n_sort = Local } + +setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name +setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc} + where + set (Global _) = Global mod +\end{code} + + +%************************************************************************ +%* * +\subsection{Predicates and selectors} +%* * +%************************************************************************ -getSynNameArity :: Name -> Maybe Arity -getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity -getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon -getSynNameArity other_name = Nothing +\begin{code} +hashName :: Name -> Int +hashName name = iBox (u2i (nameUnique name)) -getNameShortName :: Name -> ShortName -getNameShortName (Short _ sn) = sn -getNameFullName :: Name -> FullName -getNameFullName n = get_nm "getNameFullName" n +nameRdrName :: Name -> RdrName +-- Makes a qualified name for top-level (Global) names, whether locally defined or not +-- and an unqualified name just for Locals +nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrOrig (moduleName mod) occ +nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ \end{code} @@ -147,149 +245,94 @@ getNameFullName n = get_nm "getNameFullName" n %************************************************************************ \begin{code} -cmpName n1 n2 = c n1 n2 - where - c (Short u1 _) (Short u2 _) = cmp u1 u2 - - c (WiredInTyCon tc1) (WiredInTyCon tc2) = cmp tc1 tc2 - c (WiredInVal id1) (WiredInVal id2) = cmp id1 id2 - - c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) = cmp u1 u2 - c (ClassName u1 _ _) (ClassName u2 _ _) = cmp u1 u2 - c (ValName u1 _) (ValName u2 _) = cmp u1 u2 - - c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmp u1 u2 - c (Unbound a) (Unbound b) = panic# "Eq.Name.Unbound" - - c other_1 other_2 -- the tags *must* be different - = let tag1 = tag_Name n1 - tag2 = tag_Name n2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - - tag_Name (Short _ _) = (ILIT(1) :: FAST_INT) - tag_Name (WiredInTyCon _) = ILIT(2) - tag_Name (WiredInVal _) = ILIT(3) - tag_Name (TyConName _ _ _ _ _) = ILIT(7) - tag_Name (ClassName _ _ _) = ILIT(8) - tag_Name (ValName _ _) = ILIT(9) - tag_Name (ClassOpName _ _ _ _) = ILIT(10) - tag_Name (Unbound _) = ILIT(11) +cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 \end{code} \begin{code} instance Eq Name where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Name where - a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b -instance Ord3 Name where - cmp = cmpName +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n \end{code} + +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ + \begin{code} -instance NamedThing Name where - getExportFlag (Short _ _) = NotExported - getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these - getExportFlag (WiredInVal _) = NotExported - getExportFlag (ClassOpName _ c _ _) = getExportFlag c - getExportFlag other = getExportFlag (get_nm "getExportFlag" other) - - isLocallyDefined (Short _ _) = True - isLocallyDefined (WiredInTyCon _) = False - isLocallyDefined (WiredInVal _) = False - isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c - isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other) - - getOrigName (Short _ sn) = getOrigName sn - getOrigName (WiredInTyCon tc) = getOrigName tc - getOrigName (WiredInVal id) = getOrigName id - getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op) - getOrigName other = getOrigName (get_nm "getOrigName" other) - - getOccurrenceName (Short _ sn) = getOccurrenceName sn - getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc - getOccurrenceName (WiredInVal id) = getOccurrenceName id - getOccurrenceName (ClassOpName _ _ op _) = op - getOccurrenceName (Unbound s) = s _APPEND_ SLIT("") - getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other) - - getInformingModules thing = panic "getInformingModule:Name" - - getSrcLoc (Short _ sn) = getSrcLoc sn - getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc - getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc - getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c - getSrcLoc (Unbound _) = mkUnknownSrcLoc - getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other) - - getItsUnique (Short u _) = u - getItsUnique (WiredInTyCon t) = getItsUnique t - getItsUnique (WiredInVal i) = getItsUnique i - getItsUnique (TyConName u _ _ _ _) = u - getItsUnique (ClassName u _ _) = u - getItsUnique (ValName u _) = u - getItsUnique (ClassOpName u _ _ _) = u - - fromPreludeCore (WiredInTyCon _) = True - fromPreludeCore (WiredInVal _) = True - fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c - fromPreludeCore other = False +instance Outputable Name where + -- When printing interfaces, all Locals have been given nice print-names + ppr name = pprName name + +pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + Global mod -> pprGlobal sty name uniq mod occ + System -> pprSysLocal sty uniq occ + Local -> pprLocal sty uniq occ + +pprGlobal 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 "-}" + + | unqualStyle sty name = pprOccName occ + | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ + +pprLocal sty uniq occ + | codeStyle sty = pprUnique uniq + | debugStyle sty = pprOccName occ <> + text "{-" <> pprUnique uniq <> text "-}" + | otherwise = pprOccName occ -- User and Iface styles + +-- Like Local, except that we only omit the unique in Iface style +pprSysLocal sty uniq occ + | codeStyle sty = pprUnique uniq + | ifaceStyle sty = pprOccName occ -- The tidy phase has ensured + -- that OccNames are enough + | otherwise = pprOccName occ <> char '_' <> pprUnique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique \end{code} -A useful utility; most emphatically not for export! (but see -@getNameFullName@...): +%************************************************************************ +%* * +\subsection{Overloaded functions related to Names} +%* * +%************************************************************************ + \begin{code} -get_nm :: String -> Name -> FullName - -get_nm msg (TyConName _ n _ _ _) = n -get_nm msg (ClassName _ n _) = n -get_nm msg (ValName _ n) = n -#ifdef DEBUG -get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other) --- If match failure, probably on a ClassOpName or Unbound :-( -#endif +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -instance Outputable Name where -#ifdef DEBUG - ppr PprDebug (Short u s) = pp_debug u s - - ppr PprDebug (TyConName u n _ _ _) = pp_debug u n - ppr PprDebug (ClassName u n _) = pp_debug u n - ppr PprDebug (ValName u n) = pp_debug u n -#endif - ppr sty (Short u s) = ppr sty s - - ppr sty (WiredInTyCon tc) = ppr sty tc - ppr sty (WiredInVal id) = ppr sty id - - ppr sty (TyConName u n a b c) = ppr sty n - ppr sty (ClassName u n c) = ppr sty n - ppr sty (ValName u n) = ppr sty n - - ppr sty (ClassOpName u c s i) - = let - ps = ppPStr s - in - case sty of - PprForUser -> ps - PprInterface -> ps - PprDebug -> ps - other -> ppBesides [ps, ppChar '{', - ppSep [pprUnique u, - ppStr "op", ppInt i, - ppStr "cls", ppr sty c], - ppChar '}'] - - ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s) - -pp_debug uniq thing - = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] +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} +