X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=5fc667cfa3cbcf3f9ef1ebf982ab0db2494645a8;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=fcb4ecfcf021ca6b5701587c4bae8d38a04737fd;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index fcb4ecf..5fc667c 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -1,493 +1,749 @@ % -% (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 ( - Module(..), - - RdrName(..), - isUnqual, - isQual, - isRdrLexCon, - appendRdr, - showRdr, - cmpRdr, - - Name, - Provenance, - mkLocalName, isLocalName, - mkTopLevName, mkImportedName, - mkImplicitName, isImplicitName, - mkBuiltinName, mkCompoundName, - - mkFunTyConName, mkTupleDataConName, mkTupleTyConName, - mkTupNameStr, - - NamedThing(..), -- class - ExportFlag(..), - isExported{-overloaded-}, exportFlagOn{-not-}, - - nameUnique, - nameOccName, - nameOrigName, - nameExportFlag, - nameSrcLoc, - nameImpLocs, - nameImportFlag, + -- Re-export the Module type + Module, + pprModule, moduleString, + + -- The basic form of names + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + mkTupNameStr, mkUbxTupNameStr, isLowerISO, isUpperISO, + + -- The OccName type + OccName(..), varOcc, + pprOccName, occNameString, occNameFlavour, + isTvOcc, isTCOcc, isVarOcc, prefixOccName, + + -- The Name type + Name, -- Abstract + mkLocalName, mkSysLocalName, + + mkCompoundName, mkGlobalName, + + mkWiredInIdName, mkWiredInTyConName, + maybeWiredInIdName, maybeWiredInTyConName, + isWiredInName, + + nameUnique, changeUnique, setNameProvenance, getNameProvenance, + setNameVisibility, mkNameVisible, + nameOccName, nameModule, + + isExportedName, nameSrcLoc, isLocallyDefinedName, - isPreludeDefinedName, - origName, moduleOf, nameOf, moduleNamePair, - getOccName, getExportFlag, - getSrcLoc, getImpLocs, - isLocallyDefined, isPreludeDefined, - getLocalName, ltLexical, + isSysLocalName, isLocalName, isGlobalName, isExternallyVisibleName, + + pprNameProvenance, - isSymLexeme, pprSym, pprNonSym, - isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym + -- Special Names + dictNamePrefix, mkSuperDictSelName, mkWorkerName, + mkDefaultMethodName, mkClassTyConStr, mkClassDataConStr, + + -- Misc + Provenance(..), pprProvenance, + ExportFlag(..), + PrintUnqualified, + + -- Class NamedThing and overloaded friends + NamedThing(..), + modAndOcc, isExported, + getSrcLoc, isLocallyDefined, getOccString ) where -import Ubiq - -import CStrings ( identToC, cSEP ) -import Outputable ( Outputable(..) ) -import PprStyle ( PprStyle(..), codeStyle ) -import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude ) -import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, - pprUnique, Unique - ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic ) +#include "HsVersions.h" + +import {-# SOURCE #-} Var ( Id ) +import {-# SOURCE #-} TyCon ( TyCon ) + +import CStrings ( identToC ) +import PrelMods ( pREL_BASE, pREL_TUP, pREL_GHC ) +import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule ) + +import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) +import Unique ( pprUnique, Unique, Uniquable(..) ) +import Outputable +import Char ( isUpper, isLower, ord ) +import Util ( nOfThem ) +import GlaExts \end{code} + %************************************************************************ %* * -\subsection[RdrName]{The @RdrName@ datatype; names read from files} +\subsection{Lexical categories} %* * %************************************************************************ -\begin{code} -type Module = FAST_STRING - -data RdrName - = Unqual FAST_STRING - | Qual Module FAST_STRING +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. -isUnqual (Unqual _) = True -isUnqual (Qual _ _) = False +\begin{code} +isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, + isLexVarId, isLexVarSym :: FAST_STRING -> Bool -isQual (Unqual _) = False -isQual (Qual _ _) = True +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs -isRdrLexCon (Unqual n) = isLexCon n -isRdrLexCon (Qual m n) = isLexCon n +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs -appendRdr (Unqual n) str = Unqual (n _APPEND_ str) -appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) - Qual m (n _APPEND_ str) +------------- -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) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2) +isLexConId cs + | _NULL_ cs = False + | cs == SLIT("[]") = True + | c == '(' = True -- (), (,), (,,), ... + | otherwise = isUpper c || isUpperISO c + where + c = _HEAD_ cs -instance Eq RdrName where - a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } - a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } +isLexVarId cs + | _NULL_ cs = False + | otherwise = isLower c || isLowerISO c + where + c = _HEAD_ cs -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 } +isLexConSym cs + | _NULL_ cs = False + | otherwise = c == ':' + || cs == SLIT("->") + where + c = _HEAD_ cs -instance Ord3 RdrName where - cmp = cmpRdr +isLexVarSym cs + | _NULL_ cs = False + | otherwise = isSymbolASCII c + || isSymbolISO c + where + c = _HEAD_ cs -instance NamedThing RdrName where - -- We're sorta faking it here - getName rdr_name - = Global u rdr_name prov ex [rdr_name] - where - u = panic "NamedThing.RdrName:Unique" - prov = panic "NamedThing.RdrName:Provenance" - ex = panic "NamedThing.RdrName:ExportFlag" +------------- +isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) +isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# +--0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# +--0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +\end{code} -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) +\begin{code} +mkTupNameStr 0 = (pREL_BASE, SLIT("()")) +mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" +mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary +mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto +mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto +mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) + +mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???" +mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!! +mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)") +mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)") +mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)") +mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) +\end{code} -pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP] -pp_mod _ m = ppBesides [ppPStr m, ppChar '.'] -pp_name sty n | codeStyle sty = identToC n - | otherwise = ppPStr n +%************************************************************************ +%* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +%* * +%************************************************************************ -showRdr sty rdr = ppShow 100 (ppr sty rdr) +\begin{code} +data OccName = VarOcc FAST_STRING -- Variables and data constructors + | TvOcc FAST_STRING -- Type variables + | TCOcc FAST_STRING -- Type constructors and classes + +pprOccName :: OccName -> SDoc +pprOccName n = getPprStyle $ \ sty -> + if codeStyle sty + then identToC (occNameString n) + else ptext (occNameString n) + +varOcc :: FAST_STRING -> OccName +varOcc = VarOcc + +occNameString :: OccName -> FAST_STRING +occNameString (VarOcc s) = s +occNameString (TvOcc s) = s +occNameString (TCOcc s) = s + +mapOccName :: (FAST_STRING -> FAST_STRING) -> OccName -> OccName +mapOccName f (VarOcc s) = VarOcc (f s) +mapOccName f (TvOcc s) = TvOcc (f s) +mapOccName f (TCOcc s) = TCOcc (f s) + +prefixOccName :: FAST_STRING -> OccName -> OccName +prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s) +prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s) +prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s) + +-- occNameFlavour is used only to generate good error messages, so it doesn't matter +-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for +-- data constructors and values, but that makes everything else a bit more complicated. +occNameFlavour :: OccName -> String +occNameFlavour (VarOcc s) | isLexConId s = "Data constructor" + | otherwise = "Value" +occNameFlavour (TvOcc s) = "Type variable" +occNameFlavour (TCOcc s) = "Type constructor or class" + +isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool +isVarOcc (VarOcc s) = True +isVarOcc other = False + +isTvOcc (TvOcc s) = True +isTvOcc other = False + +isTCOcc (TCOcc s) = True +isTCOcc other = False + +instance Eq OccName where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord OccName where + 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 = cmpOcc a b + +(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `compare` s2 +(VarOcc s1) `cmpOcc` other2 = LT + +(TvOcc s1) `cmpOcc` (VarOcc s2) = GT +(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `compare` s2 +(TvOcc s1) `cmpOcc` other = LT + +(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `compare` s2 +(TCOcc s1) `cmpOcc` other = GT + +instance Outputable OccName where + ppr = pprOccName \end{code} + %************************************************************************ %* * -\subsection[Name-datatype]{The @Name@ datatype} +\subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ - + \begin{code} data Name = Local Unique - FAST_STRING - SrcLoc + (Maybe OccName) -- For ones that started life with a user name | Global Unique - RdrName -- original name; Unqual => prelude - Provenance -- where it came from - ExportFlag -- is it exported? - [RdrName] -- ordered occurrence names (usually just one); - -- first may be *un*qual. + Module -- The defining module + OccName -- Its name in that module + Provenance -- How it was defined +\end{code} + +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. +\begin{code} data Provenance - = LocalDef SrcLoc -- locally defined; give its source location + = NoProvenance - | Imported ExportFlag -- how it was imported - SrcLoc -- *original* source location - [SrcLoc] -- any import source location(s) + | LocalDef -- Defined locally + SrcLoc -- Defn site + ExportFlag -- Whether it's exported - | Implicit - | Builtin + | NonLocalDef -- Defined non-locally + SrcLoc -- Defined non-locally; src-loc gives defn site + IfaceFlavour -- Whether the defn site is an .hi-boot file + PrintUnqualified + + | WiredInTyCon TyCon -- There's a wired-in version + | WiredInId Id -- ...ditto... + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it + -- unqualified in error messages \end{code} -\begin{code} -mkLocalName = Local +Something is "Exported" if it may be mentioned by another module without +warning. The crucial thing about Exported things is that they must +never be dropped as dead code, even if they aren't used in this module. +Furthermore, being Exported means that we can't see all call sites of the thing. -mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs -mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs +Exported things include: -mkImplicitName :: Unique -> RdrName -> Name -mkImplicitName u o = Global u o Implicit NotExported [] + - explicitly exported Ids, including data constructors, + class method selectors -mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] + - dfuns from instance decls -mkCompoundName :: Unique -> [FAST_STRING] -> Name -mkCompoundName u ns - = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported [] - where - dotify [] = [] - dotify [n] = [n] - dotify (n:ns) = n : (map (_CONS_ '.') ns) - -mkFunTyConName - = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") -mkTupleDataConName arity - = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) -mkTupleTyConName arity - = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity) - -mkTupNameStr 0 = SLIT("()") -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary -mkTupNameStr 3 = SLIT("(,,)") -- ditto -mkTupNameStr 4 = SLIT("(,,,)") -- ditto -mkTupNameStr n - = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")") +Being Exported is *not* the same as finally appearing in the .o file's +symbol table. For example, a local Id may be mentioned in an Exported +Id's unfolding in the interface file, in which case the local Id goes +out too. - -- ToDo: what about module ??? - -- ToDo: exported when compiling builtin ??? +\begin{code} +data ExportFlag = Exported | NotExported +\end{code} -isLocalName (Local _ _ _) = True -isLocalName _ = False +\begin{code} +mkLocalName :: Unique -> OccName -> Name +mkLocalName uniq occ = Local uniq (Just occ) -isImplicitName (Global _ _ Implicit _ _) = True -isImplicitName _ = False +mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name +mkGlobalName = Global -isBuiltinName (Global _ _ Builtin _ _) = True -isBuiltinName _ = False -\end{code} +mkSysLocalName :: Unique -> Name +mkSysLocalName uniq = Local uniq Nothing +mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name +mkWiredInIdName uniq mod occ id + = Global uniq mod (VarOcc occ) (WiredInId id) +mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon + = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) -%************************************************************************ -%* * -\subsection[Name-instances]{Instance declarations} -%* * -%************************************************************************ -\begin{code} -cmpName n1 n2 = c n1 n2 - where - c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 - c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 +mkCompoundName :: (OccName -> OccName) + -> Unique -- New unique + -> Name -- Base name + -> Name -- Result is always a value name + +mkCompoundName f uniq (Global _ mod occ prov) + = Global uniq mod (f occ) prov + +mkCompoundName f uniq (Local _ (Just occ)) + = Local uniq (Just (f occ)) - 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_ +mkCompoundName f uniq (Local _ Nothing) + = Local uniq Nothing - tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT) - tag_Name (Global _ _ _ _ _) = ILIT(2) +setNameProvenance :: Name -> Provenance -> Name + -- setNameProvenance used to only change the provenance of + -- Implicit-provenance things, but that gives bad error messages + -- for names defined twice in the same module, so I changed it to + -- set the provenance of *any* global (SLPJ Jun 97) +setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov +setNameProvenance other_name prov = other_name + +getNameProvenance :: Name -> Provenance +getNameProvenance (Global uniq mod occ prov) = prov +getNameProvenance (Local uniq occ) = LocalDef noSrcLoc NotExported + +-- 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 ) u = Local u n +changeUnique (Global _ mod occ prov) u = Global u mod occ prov \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 } +setNameVisibility is applied to names in the final program -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 } +The Maybe Module argument is (Just mod) for top-level values, +and Nothing for all others (local values and type variables) -instance Ord3 Name where - cmp = cmpName +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) -instance Uniquable Name where - uniqueOf = nameUnique +For nested things it localises Global names. -instance NamedThing Name where - getName n = n -\end{code} +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} -nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _ _) = u +setNameVisibility :: Maybe Module -> Unique -> Name -> Name -nameOrigName (Local _ n _) = Unqual n -nameOrigName (Global _ orig _ _ _) = orig +setNameVisibility maybe_mod uniq name@(Global _ mod occ (LocalDef loc NotExported)) + | not all_toplev_ids_visible || not_top_level maybe_mod + = Local uniq Nothing -- Localise Global name -nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n) -nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) -nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) +setNameVisibility maybe_mod uniq name@(Global _ _ _ _) + = name -- Otherwise don't fiddle with Global -nameOccName (Local _ n _) = Unqual n -nameOccName (Global _ orig _ _ [] ) = orig -nameOccName (Global _ orig _ _ occs) = head occs +setNameVisibility (Just mod) uniq (Local _ _) + | all_toplev_ids_visible + = Global uniq mod -- Globalise Local name + (uniqToOccName uniq) + (LocalDef noSrcLoc NotExported) -nameExportFlag (Local _ _ _) = NotExported -nameExportFlag (Global _ _ _ exp _) = exp +setNameVisibility maybe_mod uniq (Local _ _) + = Local uniq Nothing -- New unique for Local; zap its occ -nameSrcLoc (Local _ _ loc) = loc -nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc -nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc -nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc -nameSrcLoc (Global _ _ Builtin _ _) = 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 _ _ Builtin _ _) = ExportAll - -isLocallyDefinedName (Local _ _ _) = True -isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True -isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False -isLocallyDefinedName (Global _ _ Implicit _ _) = False -isLocallyDefinedName (Global _ _ Builtin _ _) = False - -isPreludeDefinedName (Local _ n _) = False -isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig -\end{code} +-- make the Name globally visible regardless. +mkNameVisible :: Module -> Unique -> Name -> Name +mkNameVisible mod occ_uniq nm@(Global _ _ _ _) = nm +mkNameVisible mod occ_uniq nm@(Local uniq occ) + = Global uniq mod (uniqToOccName occ_uniq) (LocalDef noSrcLoc Exported) -\begin{code} -instance Outputable Name where -#ifdef DEBUG - ppr PprDebug (Local u n _) = pp_debug u (ppPStr n) - ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o) -#endif - ppr sty (Local u n _) = pp_name sty n - ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o - ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs) - ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs - ppr sty (Global u o _ _ _) = ppr sty o - -pp_debug uniq thing - = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] - -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 Builtin = ppPStr SLIT("/BUILTIN") -pp_prov _ = ppNil +uniqToOccName uniq = VarOcc (_PK_ ('_':show uniq)) + -- The "_" is to make sure that this OccName is distinct from all user-defined ones + +not_top_level (Just m) = False +not_top_level Nothing = True + +all_toplev_ids_visible = + not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection{Predicates and selectors} %* * %************************************************************************ -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 +nameUnique :: Name -> Unique +nameModAndOcc :: Name -> (Module, OccName) -- Globals only +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc +isLocallyDefinedName :: Name -> Bool +isExportedName :: Name -> Bool +isWiredInName :: Name -> Bool +isLocalName :: Name -> Bool +isGlobalName :: Name -> Bool +isExternallyVisibleName :: Name -> Bool + + + +nameUnique (Local u _) = u +nameUnique (Global u _ _ _) = u + +nameOccName (Local _ (Just occ)) = occ +nameOccName (Local uniq Nothing) = pprPanic "nameOccName" (ppr uniq) +nameOccName (Global _ _ occ _) = occ + +nameModule (Global _ mod occ _) = mod + +nameModAndOcc (Global _ mod occ _) = (mod,occ) + +isExportedName (Global _ _ _ (LocalDef _ Exported)) = True +isExportedName other = False + +nameSrcLoc (Local _ _) = noSrcLoc +nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc +nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc +nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc +nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc +nameSrcLoc other = noSrcLoc + +isLocallyDefinedName (Local _ _) = True +isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True +isLocallyDefinedName other = 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. +isWiredInName (Global _ _ _ (WiredInTyCon _)) = True +isWiredInName (Global _ _ _ (WiredInId _)) = True +isWiredInName _ = False + +maybeWiredInIdName :: Name -> Maybe Id +maybeWiredInIdName (Global _ _ _ (WiredInId id)) = Just id +maybeWiredInIdName other = Nothing -exportFlagOn NotExported = False -exportFlagOn _ = True +maybeWiredInTyConName :: Name -> Maybe TyCon +maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc)) = Just tc +maybeWiredInTyConName other = Nothing -isExported a = exportFlagOn (getExportFlag a) + +isLocalName (Local _ _) = True +isLocalName _ = False + +isSysLocalName (Local _ Nothing) = True +isSysLocalName other = False + +isGlobalName (Global _ _ _ _) = True +isGlobalName other = False + +-- 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 isExported). +isExternallyVisibleName name = isGlobalName name \end{code} + %************************************************************************ %* * -\subsection{Overloaded functions related to Names} +\subsection[Name-instances]{Instance declarations} %* * %************************************************************************ \begin{code} -class NamedThing a where - getName :: a -> Name +cmpName n1 n2 = c n1 n2 + where + c (Local u1 _) (Local u2 _) = compare u1 u2 + c (Local _ _) _ = LT + c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2 + c (Global _ _ _ _) _ = GT \end{code} \begin{code} -origName :: NamedThing a => a -> RdrName -moduleOf :: RdrName -> Module -nameOf :: RdrName -> FAST_STRING -moduleNamePair :: NamedThing a => a -> (Module, 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 -isPreludeDefined :: NamedThing a => a -> Bool +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } --- ToDo: specialise for RdrNames? -origName = nameOrigName . getName -moduleNamePair = nameModuleNamePair . getName +instance Ord Name where + 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 -moduleOf (Unqual n) = pRELUDE -moduleOf (Qual m n) = m +instance Uniquable Name where + getUnique = nameUnique -nameOf (Unqual n) = n -nameOf (Qual m n) = n +instance NamedThing Name where + getName n = n +\end{code} -getLocalName = nameOf . origName -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName -getSrcLoc = nameSrcLoc . getName -getImpLocs = nameImpLocs . getName -isLocallyDefined = isLocallyDefinedName . getName -isPreludeDefined = isPreludeDefinedName . getName -\end{code} +%************************************************************************ +%* * +\subsection[Special-Names]{Special Kinds of names} +%* * +%************************************************************************ -@ltLexical@ is used for sorting things into lexicographical order, so -as to canonicalize interfaces. [Regular @(<)@ should be used for fast -comparison.] +Here's our convention for splitting up the object file name space: -\begin{code} -a `ltLexical` b = origName a < origName b -\end{code} + _d... dictionary identifiers + _g... externally visible (non-user visible) names -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)@. + _m... default methods + _n... default methods (encoded symbols, eg. <= becomes _nle) -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, - isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool + _p... superclass selectors -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs + _w... workers + _v... workers (encoded symbols) -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs + _x... local variables -------------- + _u... user-defined names that previously began with '_' -isLexConId cs - | _NULL_ cs = False - | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs + _[A-Z]... compiler-generated tycons/datacons (namely dictionary + constructors) -isLexVarId cs - | _NULL_ cs = False - | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s - | otherwise = isLower c || isLowerISO c - where - c = _HEAD_ cs + __.... keywords (__export, __letrec etc.) -isLexConSym cs - | _NULL_ cs = False - | otherwise = c == ':' --- || c == '(' -- (), (,), (,,), ... - || cs == SLIT("->") --- || cs == SLIT("[]") - where - c = _HEAD_ cs +This knowledge is encoded in the following functions. -isLexVarSym cs - | _NULL_ cs = False - | otherwise = isSymbolASCII c - || isSymbolISO c --- || c == '(' -- (), (,), (,,), ... --- || cs == SLIT("[]") - where - c = _HEAD_ cs +\begin{code} +dictNamePrefix :: FAST_STRING +dictNamePrefix = SLIT("_d") + +mkSuperDictSelName :: Int -> OccName -> OccName +mkSuperDictSelName index = prefixOccName (_PK_ ("_p" ++ show index ++ "_")) + +mkWorkerName :: OccName -> OccName +mkWorkerName nm + | isLexSym nm_str = + prefixOccName SLIT("_v") (mapOccName trName nm) + | otherwise = + prefixOccName SLIT("_w") nm + where nm_str = occNameString nm + +mkDefaultMethodName :: OccName -> OccName +mkDefaultMethodName nm + | isLexSym nm_str = + prefixOccName SLIT("_n") (mapOccName trName nm) + | otherwise = + prefixOccName SLIT("_m") nm + where nm_str = occNameString nm + +-- not used yet: +--mkRecordSelectorName :: Name -> Name +--mkMethodSelectorName :: Name -> Name + +mkClassTyConStr, mkClassDataConStr :: FAST_STRING -> FAST_STRING + +mkClassTyConStr s = SLIT("_") _APPEND_ s +mkClassDataConStr s = SLIT("_") _APPEND_ s + +-- translate a string such that it can occur as *part* of an identifer. This +-- is used when we prefix identifiers to create new names, for example the +-- name of a default method. + +trName :: FAST_STRING -> FAST_STRING +trName nm = _PK_ (foldr tran "" (_UNPK_ nm)) + where + tran c cs = case trChar c of + '\0' -> '_' : show (ord c) ++ cs + c' -> c' : cs + trChar '&' = 'a' + trChar '|' = 'b' + trChar ':' = 'c' + trChar '/' = 'd' + trChar '=' = 'e' + trChar '>' = 'g' + trChar '#' = 'h' + trChar '@' = 'i' + trChar '<' = 'l' + trChar '-' = 'm' + trChar '!' = 'n' + trChar '+' = 'p' + trChar '\'' = 'q' + trChar '$' = 'r' + trChar '?' = 's' + trChar '*' = 't' + trChar '_' = 'u' + trChar '.' = 'v' + trChar '\\' = 'w' + trChar '%' = 'x' + trChar '~' = 'y' + trChar '^' = 'z' + trChar _ = '\0' +\end{code} -isLexSpecialSym cs - | _NULL_ cs = False - | otherwise = c == '(' -- (), (,), (,,), ... - || cs == SLIT("[]") - where - c = _HEAD_ cs +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ -------------- -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 +\begin{code} +instance Outputable Name where + -- When printing interfaces, all Locals have been given nice print-names + ppr name = pprName name + +pprName name + = getPprStyle $ \ sty -> + let + -- when printing local names for interface files, prepend the '_' + -- to avoid clashes with user-defined names. In fact, these names + -- will always begin with 'g' for top-level ids and 'x' otherwise, + -- because these are the unique supplies going into the tidy phase. + ppr (Local u n) | codeStyle sty = pprUnique u + | ifaceStyle sty = char '_' <> pprUnique u + + ppr (Local u Nothing) = pprUnique u + ppr (Local u (Just occ)) | userStyle sty = ptext (occNameString occ) + | otherwise = ptext (occNameString occ) <> char '_' <> pprUnique u + + ppr name@(Global u m n prov) + | codeStyle sty + = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) + + | otherwise + = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] + where + pp_mod_dot + = case prov of -- Omit home module qualifier if in scope + LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) + NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) + -- Hack: omit qualifers on wired in things + -- in user style only + WiredInTyCon _ -> pp_qual dot user_sty + WiredInId _ -> pp_qual dot user_sty + NoProvenance -> pp_qual dot False + + pp_qual sep omit_qual + | omit_qual = empty + | otherwise = pprModule m <> sep + + dot = text "." + pp_hif HiFile = dot -- Vanilla case + pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface + + user_sty = userStyle sty + iface_sty = ifaceStyle sty + in + ppr name + + +pp_debug sty (Global uniq m n prov) + | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"] + | otherwise = empty + where + prov_p | opt_PprStyle_NoPrags = empty + | otherwise = comma <> pp_prov prov + +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef _ _ _) = char 'n' +pp_prov (WiredInTyCon _) = char 'W' +pp_prov (WiredInId _) = char 'w' +pp_prov NoProvenance = char '?' + +-- pprNameProvenance is used in error messages to say where a name came from +pprNameProvenance :: Name -> SDoc +pprNameProvenance (Local _ _) = pprProvenance (LocalDef noSrcLoc NotExported) +pprNameProvenance (Global _ _ _ prov) = pprProvenance prov + +pprProvenance :: Provenance -> SDoc +pprProvenance (LocalDef loc _) = ptext SLIT("Locally defined at") <+> ppr loc +pprProvenance (NonLocalDef loc _ _) = ptext SLIT("Non-locally defined at") <+> ppr loc +pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") +pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") +pprProvenance NoProvenance = ptext SLIT("No provenance") \end{code} -And one ``higher-level'' interface to those: + +%************************************************************************ +%* * +\subsection{Overloaded functions related to Names} +%* * +%************************************************************************ \begin{code} -isSymLexeme :: NamedThing a => a -> Bool +class NamedThing a where + getOccName :: a -> OccName -- Even RdrNames can do this! + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method +\end{code} -isSymLexeme v - = let str = nameOf (origName v) in isLexSym str +\begin{code} +modAndOcc :: NamedThing a => a -> (Module, OccName) +getSrcLoc :: NamedThing a => a -> SrcLoc +isLocallyDefined :: NamedThing a => a -> Bool +isExported :: NamedThing a => a -> Bool +getOccString :: NamedThing a => a -> String --- print `vars`, (op) correctly -pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty +modAndOcc = nameModAndOcc . getName +isExported = isExportedName . getName +getSrcLoc = nameSrcLoc . getName +isLocallyDefined = isLocallyDefinedName . getName +getOccString x = _UNPK_ (occNameString (getOccName x)) +\end{code} -pprSym sty var - = let - str = nameOf (origName 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 +\begin{code} +{-# SPECIALIZE isLocallyDefined + :: Name -> Bool + #-} \end{code}