X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=554c3bdc6ce65c68f50272f31c97d1712f37317a;hb=12467fbf505554bb20d0a3502dc162d605373da5;hp=d3eb0d5541b8fa9e96c624d8c0ae11a0e7ba8e7c;hpb=573ef10b2afd99d3c6a36370a9367609716c97d2;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index d3eb0d5..554c3bd 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -1,333 +1,382 @@ % -% (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 ( - SYN_IE(Module), - - OrigName(..), -- glorified pair - qualToOrigName, -- a Qual to an OrigName - - RdrName(..), - preludeQual, - moduleNamePair, - isUnqual, - isQual, - isRdrLexCon, isRdrLexConOrSpecial, - appendRdr, - showRdr, - cmpRdr, - - Name, - Provenance, - mkLocalName, isLocalName, - mkTopLevName, mkImportedName, oddlyImportedName, - mkImplicitName, isImplicitName, - mkPrimitiveName, mkWiredInName, - mkCompoundName, mkCompoundName2, - - mkFunTyConName, mkTupleDataConName, mkTupleTyConName, - mkTupNameStr, - - NamedThing(..), -- class - ExportFlag(..), - isExported{-overloaded-}, exportFlagOn{-not-}, - - nameUnique, changeUnique, - nameOccName, --- nameOrigName, : not exported - nameExportFlag, - nameSrcLoc, - nameImpLocs, - nameImportFlag, - isLocallyDefinedName, isWiredInName, - - origName, moduleOf, nameOf, - getOccName, getExportFlag, - getSrcLoc, getImpLocs, - isLocallyDefined, - getLocalName, - - isSymLexeme, pprSym, pprNonSym, - isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym + -- Re-export the OccName stuff + module OccName, + + -- The Name type + Name, -- Abstract + mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, + mkTopName, mkIPName, + mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInName, + + nameUnique, setNameUnique, setLocalNameSort, + tidyTopName, + nameOccName, nameModule, nameModule_maybe, + setNameOcc, nameRdrName, setNameModuleAndLoc, + toRdrName, hashName, + + isUserExportedName, + nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom, + + isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + isTyVarName, + + -- Environment + NameEnv, mkNameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv, foldNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, + + + -- Class NamedThing and overloaded friends + NamedThing(..), + getSrcLoc, isLocallyDefined, getOccString, toRdrName, + isFrom, isLocalOrFrom ) where -IMP_Ubiq() -IMPORT_1_3(Char(isUpper,isLower)) - -import CmdLineOpts ( maybe_CompilingGhcInternals ) -import CStrings ( identToC, modnameToC, cSEP ) -import Outputable ( Outputable(..) ) -import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE ) -import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, - pprUnique, Unique - ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} ) - -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif +#include "HsVersions.h" + +import OccName -- All of it +import Module ( Module, moduleName, mkVanillaModule, + printModulePrefix, isModuleInThisPackage ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 ) +import FastTypes +import Maybes ( expectJust ) +import UniqFM +import Outputable \end{code} %************************************************************************ %* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ - + \begin{code} -type Module = FAST_STRING - -data OrigName = OrigName Module FAST_STRING +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 + } -qualToOrigName (Qual m n) = OrigName m n +data NameSort + = Global Module -- (a) TyCon, Class, their derived Ids, dfun Id + -- (b) imported Id -data RdrName - = Unqual FAST_STRING - | Qual Module FAST_STRING + | Exported -- An exported Ids defined in the module being compiled -preludeQual n = Qual pRELUDE n + | Local -- A user-defined, but non-exported Id or TyVar, + -- defined in the module being compiled -moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this - -- constitutes an original name or - -- an occurrence name, or anything else - -isUnqual (Unqual _) = True -isUnqual (Qual _ _) = False + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') +\end{code} -isQual (Unqual _) = False -isQual (Qual _ _) = True +Notes about the NameSorts: -isRdrLexCon (Unqual n) = isLexCon n -isRdrLexCon (Qual m n) = isLexCon n +1. An Exported Id is changed to Global right at the + end in the tidyCore pass, so that an importer sees a Global + Similarly, Local Ids that are visible to an importer (e.g. when + optimisation is on) are changed to Globals. -isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n -isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n +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. -appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = Qual m (n _APPEND_ str) +3. 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 -cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 -cmpRdr (Unqual n1) (Qual m2 n2) = LT_ -cmpRdr (Qual m1 n1) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 - -- always compare module-names *second* + 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. -cmpOrig (OrigName m1 n1) (OrigName m2 n2) - = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second* +\begin{code} +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc -instance Eq RdrName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameSrcLoc name = n_loc name -instance Ord RdrName 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 } +nameModule (Name { n_sort = Global mod }) = mod +nameModule name = pprPanic "nameModule" (ppr name) -instance Ord3 RdrName where - cmp = cmpRdr +nameModule_maybe (Name { n_sort = Global mod }) = Just mod +nameModule_maybe name = Nothing +\end{code} -instance NamedThing RdrName where - -- We're sorta faking it here - getName (Unqual n) - = Local u n True locn - where - u = panic "NamedThing.RdrName:Unique1" - locn = panic "NamedThing.RdrName:locn" +\begin{code} +nameIsLocallyDefined :: Name -> Bool +nameIsFrom :: Module -> Name -> Bool +nameIsLocalOrFrom :: Module -> Name -> Bool +isUserExportedName :: Name -> Bool +isLocalName :: Name -> Bool -- Not globals +isGlobalName :: Name -> Bool +isSystemName :: Name -> Bool +isExternallyVisibleName :: Name -> Bool - getName rdr_name@(Qual m n) - = Global u m (Left n) prov ex [rdr_name] - where - u = panic "NamedThing.RdrName:Unique" - prov = panic "NamedThing.RdrName:Provenance" - ex = panic "NamedThing.RdrName:ExportFlag" +isGlobalName (Name {n_sort = Global _}) = True +isGlobalName other = False -instance Outputable RdrName where - ppr sty (Unqual n) = pp_name sty n - ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n) +isLocalName name = not (isGlobalName name) -pp_mod sty m - = case sty of - PprForC -> pp_code - PprForAsm False _ -> pp_code - PprForAsm True _ -> ppBeside (ppPStr cSEP) pp_code - _ -> ppBeside (ppPStr m) (ppChar '.') - where - pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP) +nameIsLocallyDefined name = isLocalName name -pp_name sty n = (if codeStyle sty then identToC else ppPStr) n +nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from +nameIsLocalOrFrom from other = True -pp_name2 sty pieces - = ppIntersperse sep (map pp_piece pieces) - where - sep = if codeStyle sty then ppPStr cSEP else ppChar '.' +nameIsFrom from (Name {n_sort = Global mod}) = mod == from +nameIsFrom from other = pprPanic "nameIsFrom" (ppr other) - pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n) - pp_piece (Right n) = pp_name sty n +-- 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 (that's isUserExported). +isExternallyVisibleName name = isGlobalName name -showRdr sty rdr = ppShow 100 (ppr sty rdr) +-- Constructors, selectors and suchlike Globals, and are all exported +-- Other Local things may or may not be exported +isUserExportedName (Name { n_sort = Exported }) = True +isUserExportedName (Name { n_sort = Global _ }) = True +isUserExportedName other = False -------------------------- -instance Eq OrigName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } +isSystemName (Name {n_sort = System}) = True +isSystemName other = False +\end{code} -instance Ord OrigName 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 } -instance Ord3 OrigName where - cmp = cmpOrig +%************************************************************************ +%* * +\subsection{Making names} +%* * +%************************************************************************ -instance NamedThing OrigName where -- faking it - getName (OrigName m n) = getName (Qual m n) +\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) + +mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name + -- Just the same as mkLocalName, except the provenance is different + -- Reason: this flags the name as one that came in from an interface + -- file. This is useful when trying to decide which of two type + -- variables should 'win' when unifying them. + -- NB: this is only for non-top-level names, so we use ImplicitImport + -- + -- Oct 00: now that Names lack Provenances, mkImportedLocalName doesn't make + -- sense any more, so it's just the same as mkLocalName +mkImportedLocalName uniq occ loc = mkLocalName uniq occ loc + + +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 } + +mkCCallName :: Unique -> EncodedString -> Name + -- The encoded string completely describes the ccall +mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local, + n_occ = mkCCallOcc str, n_loc = noSrcLoc } + +mkIPName :: Unique -> OccName -> Name +mkIPName uniq occ + = Name { n_uniq = uniq, + n_sort = Local, + n_occ = occ, + n_loc = noSrcLoc } + +--------------------------------------------------------------------- +mkDerivedName :: (OccName -> OccName) + -> Name -- Base name + -> Unique -- New unique + -> Name -- Result is always a value name + +mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} +\end{code} -instance Outputable OrigName where -- ditto - ppr sty (OrigName m n) = ppr sty (Qual m n) +\begin{code} +-- 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 + -- Give the thing a new OccName, *and* + -- record that it's no longer a sys-local + -- This is used by the tidy-up pass +setNameOcc name occ = name {n_occ = occ} + +setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name +setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc} + where + set (Global _) = Global mod + +setLocalNameSort :: Name -> Bool -> Name + -- Set the name's sort to Local or Exported, depending on the boolean +setLocalNameSort name is_exported = name { n_sort = if is_exported then Exported + else Local } \end{code} + %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection{Tidying a name} %* * %************************************************************************ +tidyTopName is applied to top-level names in the final program + +For top-level things, + it globalises Local names + (if all top-level things should be visible) + and localises non-exported Global names + (if only exported things should be visible) + +In all cases except an exported global, it gives it a new occurrence name. + +The "visibility" here concerns whether the .o file's symbol table +mentions the thing; if so, it needs a module name in its symbol. +The Global things are "visible" and the Local ones are not + +Why should things be "visible"? Certainly they must be if they +are exported. But also: + +(a) In certain (prelude only) modules we split up the .hc file into + lots of separate little files, which are separately compiled by the C + compiler. That gives lots of little .o files. The idea is that if + you happen to mention one of them you don't necessarily pull them all + in. (Pulling in a piece you don't need can be v bad, because it may + mention other pieces you don't need either, and so on.) + + Sadly, splitting up .hc files means that local names (like s234) are + now globally visible, which can lead to clashes between two .hc + files. So unlocaliseWhatnot goes through making all the local things + into global things, essentially by giving them full names so when they + are printed they'll have their module name too. Pretty revolting + really. + +(b) When optimisation is on we want to make all the internal + top-level defns externally visible + \begin{code} -data Name - = Local Unique - FAST_STRING - Bool -- True <=> emphasize Unique when - -- printing; this is just an esthetic thing... - SrcLoc - - | Global Unique - Module -- original name - (Either - FAST_STRING -- just an ordinary M.n name... or... - ([Either OrigName FAST_STRING])) - -- "dot" these bits of name together... - Provenance -- where it came from - ExportFlag -- is it exported? - [RdrName] -- ordered occurrence names (usually just one); - -- first may be *un*qual. - -data Provenance - = LocalDef SrcLoc -- locally defined; give its source location - - | Imported ExportFlag -- how it was imported - SrcLoc -- *original* source location - [SrcLoc] -- any import source location(s) - - | Implicit - | Primitive -- really and truly primitive thing (not - -- definable in Haskell) - | WiredIn Bool -- something defined in Haskell; True <=> - -- definition is in the module in question; - -- this probably comes from the -fcompiling-prelude=... - -- flag. +tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) +tidyTopName mod env + name@(Name { n_occ = occ, n_sort = sort, n_uniq = uniq, n_loc = loc }) + = case sort of + System -> localise -- System local Ids + Local -> localise -- User non-exported Ids + Exported -> globalise -- User-exported things + Global _ -> no_op -- Constructors, class selectors etc + + where + no_op = (env, name) + + globalise = (env, name { n_sort = Global mod }) -- Don't change occurrence name + + localise = (env', name') + (env', occ') = tidyOccName env occ + name' = name { n_occ = occ', n_sort = mkLocalTopSort mod } + +mkTopName :: Unique -> Module -> FAST_STRING -> Name + -- Make a top-level name; make it Global if top-level + -- things should be externally visible; Local otherwise + -- This chap is only used *after* the tidyCore phase + -- Notably, it is used during STG lambda lifting + -- + -- We have to make sure that the name is globally unique + -- and we don't have tidyCore to help us. So we append + -- the unique. Hack! Hack! + -- (Used only by the STG lambda lifter.) +mkTopName uniq mod fs + = Name { n_uniq = uniq, + n_sort = mkLocalTopSort mod, + n_occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), + n_loc = noSrcLoc } + +mkLocalTopSort :: Module -> NameSort +mkLocalTopSort mod + | all_toplev_ids_visible = Global mod + | otherwise = Local + +all_toplev_ids_visible + = not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} + + +%************************************************************************ +%* * +\subsection{Predicates and selectors} +%* * +%************************************************************************ + \begin{code} -mkLocalName = Local +hashName :: Name -> Int +hashName name = iBox (u2i (nameUnique name)) -mkTopLevName u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs -mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs -mkImplicitName :: Unique -> OrigName -> Name -mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported [] +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 }) = mkRdrQual (moduleName mod) occ +nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ -mkPrimitiveName :: Unique -> OrigName -> Name -mkPrimitiveName u (OrigName m n) = Global u m (Left n) Primitive NotExported [] +ifaceNameRdrName :: Name -> RdrName +-- Makes a qualified naem for imported things, +-- and an unqualified one for local things +ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n) + | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n) + +isDllName :: Name -> Bool + -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && + not (nameIsLocallyDefined nm) && -- isLocallyDefinedName test needed 'cos + not (isModuleInThisPackage (nameModule nm)) -- nameModule won't work on local names + + + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) -mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name -mkWiredInName u (OrigName m n) exp - = Global u m (Left n) (WiredIn from_here) exp [] - where - from_here - = case maybe_CompilingGhcInternals of - Nothing -> False - Just mod -> mod == _UNPK_ m - -mkCompoundName :: Unique - -> Module - -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") - -> [Either OrigName FAST_STRING] -- "dot" these names together - -> Name -- from which we get provenance, etc.... - -> Name -- result! - -mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers... - = Local u str True{-emph uniq-} locn - -mkCompoundName u m str ns (Global _ _ _ prov exp _) - = Global u m (Right (Right str : ns)) prov exp [] - -glue = glue1 -glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns -glue1 (Right n :ns) = n : glue2 ns -glue2 [] = [] -glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns -glue2 (Right n :ns) = _CONS_ '.' n : glue2 ns - --- this ugly one is used for instance-y things -mkCompoundName2 :: Unique - -> Module - -> FAST_STRING -- indicates what kind of compound thing it is - -> [Either OrigName FAST_STRING] -- "dot" these names together - -> Bool -- True <=> defined in this module - -> SrcLoc - -> Name -- result! - -mkCompoundName2 u m str ns from_here locn - = Global u m (Right (Right str : ns)) - (if from_here then LocalDef locn else Imported ExportAll locn []) - ExportAll{-instances-} - [] - -mkFunTyConName - = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->")) -mkTupleDataConName arity - = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll -mkTupleTyConName arity - = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll - -mkTupNameStr 0 = SLIT("()") -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary -mkTupNameStr 3 = _PK_ "(,,)" -- ditto -mkTupNameStr 4 = _PK_ "(,,,)" -- ditto -mkTupNameStr n - = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") - - -- ToDo: what about module ??? - -- ToDo: exported when compiling builtin ??? - -isLocalName (Local _ _ _ _) = True -isLocalName _ = False - --- things the compiler "knows about" are in some sense --- "imported". When we are compiling the module where --- the entities are defined, we need to be able to pick --- them out, often in combination with isLocallyDefined. -oddlyImportedName (Global _ _ _ Primitive _ _) = True -oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True -oddlyImportedName _ = False - -isImplicitName (Global _ _ _ Implicit _ _) = True -isImplicitName _ = False \end{code} + %************************************************************************ %* * \subsection[Name-instances]{Instance declarations} @@ -335,153 +384,111 @@ isImplicitName _ = False %************************************************************************ \begin{code} -cmpName n1 n2 = c n1 n2 - where - c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2 - c (Local _ _ _ _) _ = LT_ - c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2 - c (Global _ _ _ _ _ _) _ = GT_ +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 } - -instance Ord3 Name where - cmp = cmpName + 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 Uniquable Name where - uniqueOf = nameUnique + getUnique = nameUnique instance NamedThing Name where getName n = n \end{code} -\begin{code} -nameUnique (Local u _ _ _) = u -nameUnique (Global u _ _ _ _ _) = u --- 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. -changeUnique (Local _ n b l) u = Local u n b l -changeUnique (Global _ m n p e os) u = Global u m n p e os - -nameOrigName msg (Global _ m (Left n) _ _ _) = OrigName m n -nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in - pprTrace ("nameOrigName:"++msg) (ppPStr str) $ - OrigName m str -#ifdef DEBUG -nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n) -#endif - -nameOccName (Local _ n _ _) = Unqual n -nameOccName (Global _ m (Left n) _ _ [] ) = Qual m n -nameOccName (Global _ m (Right n) _ _ [] ) = let str = _CONCAT_ (glue n) in - pprTrace "nameOccName:" (ppPStr str) $ - Qual m str -nameOccName (Global _ m (Left _) _ _ (o:_)) = o -nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name" - -nameExportFlag (Local _ _ _ _) = NotExported -nameExportFlag (Global _ _ _ _ exp _) = exp - -nameSrcLoc (Local _ _ _ loc) = loc -nameSrcLoc (Global _ _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc -nameSrcLoc (Global _ _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ _ Primitive _ _) = mkBuiltinSrcLoc -nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc - -nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs -nameImpLocs _ = [] - -nameImportFlag (Local _ _ _ _) = NotExported -nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll -nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp -nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll -nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll -nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll - -isLocallyDefinedName (Local _ _ _ _) = True -isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False -isLocallyDefinedName (Global _ _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ _ Primitive _ _) = False -isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here - -isWiredInName (Global _ _ _ (WiredIn _) _ _) = True -isWiredInName _ = False -\end{code} +%************************************************************************ +%* * +\subsection{Name environment} +%* * +%************************************************************************ \begin{code} -instance Outputable Name where - ppr sty (Local u n emph_uniq _) - | codeStyle sty = pprUnique u - | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] - | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"] - - ppr PprDebug (Global u m (Left n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprDebug (Global u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] - - ppr PprForUser (Global u m (Left n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name PprForUser n) - ppr PprForUser (Global u m (Right n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n) - ppr PprForUser (Global u m (Left _) _ _ occs) = ppr PprForUser (head occs) - --- LATER:? --- ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs - - ppr sty (Global u m (Left n) _ _ _) = ppBeside (pp_mod sty m) (pp_name sty n) - ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n) - -pp_all orig prov exp occs - = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] - -pp_exp NotExported = ppNil -pp_exp ExportAll = ppPStr SLIT("/EXP(..)") -pp_exp ExportAbs = ppPStr SLIT("/EXP") - -pp_prov Implicit = ppPStr SLIT("/IMPLICIT") -pp_prov Primitive = ppPStr SLIT("/PRIMITIVE") -pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN") -pp_prov _ = ppNil +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +mkNameEnv :: [(Name,a)] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b +foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b + +emptyNameEnv = emptyUFM +foldNameEnv = foldUFM +mkNameEnv = listToUFM +nameEnvElts = eltsUFM +extendNameEnv_C = addToUFM_C +extendNameEnv = addToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnvList= addListToUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM +mapNameEnv = mapUFM +unitNameEnv = unitUFM + +lookupNameEnv = lookupUFM +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) \end{code} + %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection{Pretty printing} %* * %************************************************************************ -The export flag @ExportAll@ means `export all there is', so there are -times when it is attached to a class or data type which has no -ops/constructors (if the class/type was imported abstractly). In -fact, @ExportAll@ is attached to everything except to classes/types -which are being {\em exported} abstractly, regardless of how they were -imported. - \begin{code} -data ExportFlag - = ExportAll -- export with all constructors/methods - | ExportAbs -- export abstractly (tycons/classes only) - | NotExported - -exportFlagOn NotExported = False -exportFlagOn _ = True - --- Be very wary about using "isExported"; perhaps you --- really mean "externallyVisibleId"? - -isExported a = exportFlagOn (getExportFlag a) +instance Outputable Name where + -- When printing interfaces, all Locals have been given nice print-names + ppr name = pprName name + +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + Global mod -> pprGlobal sty uniq mod occ + System -> pprSysLocal sty uniq occ + Local -> pprLocal sty uniq occ empty + Exported -> pprLocal sty uniq occ (char 'x') + +pprLocal sty uniq occ pp_export + | codeStyle sty = pprUnique uniq + | debugStyle sty = pprOccName occ <> + text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}" + | otherwise = pprOccName occ + +pprGlobal sty uniq mod occ + | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ + | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> + text "{-" <> pprUnique10 uniq <> text "-}" + | printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ + | otherwise = pprOccName occ + +pprSysLocal sty uniq occ + | codeStyle sty = pprUnique uniq + | otherwise = pprOccName occ <> char '_' <> pprUnique uniq \end{code} + %************************************************************************ %* * \subsection{Overloaded functions related to Names} @@ -490,140 +497,28 @@ isExported a = exportFlagOn (getExportFlag a) \begin{code} class NamedThing a where - getName :: a -> Name + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method \end{code} \begin{code} -origName :: NamedThing a => String -> a -> OrigName -moduleOf :: OrigName -> Module -nameOf :: OrigName -> FAST_STRING - -getOccName :: NamedThing a => a -> RdrName -getLocalName :: NamedThing a => a -> FAST_STRING -getExportFlag :: NamedThing a => a -> ExportFlag getSrcLoc :: NamedThing a => a -> SrcLoc -getImpLocs :: NamedThing a => a -> [SrcLoc] isLocallyDefined :: NamedThing a => a -> Bool +getOccString :: NamedThing a => a -> String +toRdrName :: NamedThing a => a -> RdrName +isFrom :: NamedThing a => Module -> a -> Bool +isLocalOrFrom :: NamedThing a => Module -> a -> Bool -origName str n = nameOrigName str (getName n) - -moduleOf (OrigName m n) = m -nameOf (OrigName m n) = n - -getLocalName n - = case (getName n) of - Local _ n _ _ -> n - Global _ m (Left n) _ _ _ -> n - Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in - -- pprTrace "getLocalName:" (ppPStr str) $ - str - -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName getSrcLoc = nameSrcLoc . getName -getImpLocs = nameImpLocs . getName -isLocallyDefined = isLocallyDefinedName . getName -\end{code} - -\begin{code} -{-# SPECIALIZE getLocalName - :: Name -> FAST_STRING - , OrigName -> FAST_STRING - , RdrName -> FAST_STRING - , RnName -> FAST_STRING - #-} -{-# SPECIALIZE isLocallyDefined - :: Name -> Bool - , RnName -> Bool - #-} -{-# SPECIALIZE origName - :: String -> Name -> OrigName - , String -> RdrName -> OrigName - , String -> RnName -> OrigName - #-} +isLocallyDefined = nameIsLocallyDefined . getName +getOccString = occNameString . getOccName +toRdrName = ifaceNameRdrName . getName +isFrom mod x = nameIsFrom mod (getName x) +isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x) \end{code} -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. Normally applied as in e.g. @isCon -(getLocalName foo)@. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, - isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- - -isLexConId cs - | _NULL_ cs = False - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs - -isLexVarId cs - | _NULL_ cs = False - | otherwise = isLower c || isLowerISO c - where - c = _HEAD_ cs - -isLexConSym cs - | _NULL_ cs = False - | otherwise = c == ':' --- || c == '(' -- (), (,), (,,), ... - || cs == SLIT("->") --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexVarSym cs - | _NULL_ cs = False - | otherwise = isSymbolASCII c - || isSymbolISO c --- || c == '(' -- (), (,), (,,), ... --- || cs == SLIT("[]") - where - c = _HEAD_ cs - -isLexSpecialSym cs - | _NULL_ cs = False - | otherwise = c == '(' -- (), (,), (,,), ... - || cs == SLIT("[]") - where - c = _HEAD_ cs - -------------- -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c -\end{code} - -And one ``higher-level'' interface to those: - \begin{code} -isSymLexeme :: NamedThing a => a -> Bool - -isSymLexeme v - = let str = getLocalName v in isLexSym str - --- print `vars`, (op) correctly -pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty - -pprSym sty var - = let - str = getLocalName var - in - if isLexSym str && not (isLexSpecialSym str) - then ppr sty var - else ppBesides [ppChar '`', ppr sty var, ppChar '`'] - -pprNonSym sty var - = if isSymLexeme var - then ppParens (ppr sty var) - else ppr sty var +{-# SPECIALIZE isLocallyDefined :: Name -> Bool #-} \end{code}