X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=a645419b04a506863d0ea56746b7485d233d258e;hb=30d559930fff086ad3a8ef4162e7d748d1e96b70;hp=3b0cd48b3e5a545d6a84380affd4d02756095685;hpb=266fadd93461d4317967df08cd641e965cd8769a;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 3b0cd48..a645419 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,22 +10,32 @@ module Name ( -- The Name type Name, -- Abstract - mkLocalName, mkImportedLocalName, mkSysLocalName, + mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, - mkWiredInIdName, mkWiredInTyConName, + mkWiredInIdName, mkWiredInTyConName, + maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, hashName, nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName, - isUserExportedName, isUserImportedExplicitlyName, nameSrcLoc, - isLocallyDefinedName, + isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, + maybeUserImportedFrom, + nameSrcLoc, isLocallyDefinedName, isDllName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + isTyVarName, + -- Environment + NameEnv, mkNameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, + -- Provenance Provenance(..), ImportReason(..), pprProvenance, @@ -34,23 +44,25 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, isLocallyDefined, getOccString + getSrcLoc, isLocallyDefined, getOccString, toRdrName ) where #include "HsVersions.h" -import {-# SOURCE #-} Var ( Id, setIdName ) -import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) +import {-# SOURCE #-} Var ( Id ) +import {-# SOURCE #-} TyCon ( TyCon ) import OccName -- All of it -import Module ( Module, moduleName, pprModule, mkVanillaModule ) +import Module ( Module, moduleName, pprModule, mkVanillaModule, isLocalModule ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) -import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) -import Unique ( pprUnique, Unique, Uniquable(..), u2i ) +import SrcLoc ( noSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), u2i, hasKey, pprUnique ) +import Maybes ( expectJust ) +import FastTypes +import UniqFM import Outputable -import GlaExts \end{code} @@ -108,15 +120,21 @@ mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_prov = prov } -mkKnownKeyGlobal :: (RdrName, Unique) -> Name -mkKnownKeyGlobal (rdr_name, uniq) +mkKnownKeyGlobal :: RdrName -> Unique -> Name +mkKnownKeyGlobal rdr_name uniq = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) (rdrNameOcc rdr_name) systemProvenance mkSysLocalName :: Unique -> UserFS -> Name mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, - n_occ = mkSrcVarOcc fs, n_prov = systemProvenance } + n_occ = mkVarOcc fs, n_prov = systemProvenance } + +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_prov = NonLocalDef ImplicitImport True } mkTopName :: Unique -> Module -> FAST_STRING -> Name -- Make a top-level name; make it Global if top-level @@ -130,14 +148,15 @@ mkTopName :: Unique -> Module -> FAST_STRING -> Name mkTopName uniq mod fs = Name { n_uniq = uniq, n_sort = mk_top_sort mod, - n_occ = mkSrcVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), + n_occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), n_prov = LocalDef noSrcLoc NotExported } mkIPName :: Unique -> OccName -> Name mkIPName uniq occ = Name { n_uniq = uniq, n_sort = Local, - n_occ = mkIPOcc occ, + n_occ = occ, + -- ZZ is this an appropriate provinence? n_prov = SystemProv } ------------------------- Wired in names ------------------------- @@ -146,13 +165,10 @@ mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name mkWiredInIdName uniq mod occ id = Name { n_uniq = uniq, n_sort = WiredInId mod id, n_occ = occ, n_prov = SystemProv } --- mkWiredInTyConName takes a FAST_STRING instead of --- an OccName, which is a bit yukky but that's what the --- clients find easiest. -mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name -mkWiredInTyConName uniq mod fs tycon +mkWiredInTyConName :: Unique -> Module -> OccName -> TyCon -> Name +mkWiredInTyConName uniq mod occ tycon = Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon, - n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv } + n_occ = occ, n_prov = SystemProv } --------------------------------------------------------------------- @@ -162,7 +178,9 @@ mkDerivedName :: (OccName -> OccName) -> Name -- Result is always a value name mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} +\end{code} +\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. @@ -240,6 +258,7 @@ all_toplev_ids_visible = opt_EnsureSplittableC -- Splitting requires visiblilty \end{code} + \begin{code} setNameProvenance :: Name -> Provenance -> Name -- setNameProvenance used to only change the provenance of @@ -384,7 +403,7 @@ isExternallyVisibleName :: Name -> Bool hashName :: Name -> Int -hashName name = IBOX( u2i (nameUnique name) ) +hashName name = iBox (u2i (nameUnique name)) nameUnique name = n_uniq name nameOccName name = n_occ name @@ -399,15 +418,36 @@ nameSortModule (WiredInId mod _) = mod nameSortModule (WiredInTyCon mod _) = mod 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_sort = Local, n_occ = occ }) = mkRdrUnqual occ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ +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) + isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True isUserExportedName other = False isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit isUserImportedExplicitlyName other = False +isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True +isUserImportedName other = False + +maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m +maybeUserImportedFrom other = Nothing + +isDllName :: Name -> Bool + -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && + not (isLocallyDefinedName nm) && +-- isLocallyDefinedName test is needed because nameModule won't work on local names + not (isLocalModule (nameModule nm)) + nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc @@ -441,19 +481,25 @@ isLocalName _ = False isGlobalName (Name {n_sort = Local}) = False isGlobalName other = True +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 (that's isExported). isExternallyVisibleName name = isGlobalName name hasBetterProv :: Name -> Name -> Bool -hasBetterProv name1 name2 - = case n_prov name1 of - LocalDef _ _ -> True - SystemProv -> False - NonLocalDef _ _ -> case n_prov name2 of - LocalDef _ _ -> False - other -> True +-- Choose +-- a local thing over an imported thing +-- a user-imported thing over a non-user-imported thing +-- an explicitly-imported thing over an implicitly imported thing +hasBetterProv n1 n2 + = case (n_prov n1, n_prov n2) of + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False isSystemName (Name {n_prov = SystemProv}) = True isSystemName other = False @@ -492,6 +538,48 @@ instance NamedThing Name where %************************************************************************ %* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} +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 + +emptyNameEnv = emptyUFM +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{Pretty printing} %* * %************************************************************************ @@ -589,10 +677,12 @@ class NamedThing a where getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String +toRdrName :: NamedThing a => a -> RdrName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName getOccString x = occNameString (getOccName x) +toRdrName = ifaceNameRdrName . getName \end{code} \begin{code}