X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=ff8096a9298862f0586d258cf02eeac320eee2bc;hb=2a0ffd1c424b2c076506841a55fa6f45d85329bb;hp=c895f1814e81a947907ddf77995465a7c06dab62;hpb=0554dc08d9e05e812d264a682679b798fce1ff78;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c895f18..ff8096a 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,31 +10,41 @@ module Name ( -- The Name type Name, -- Abstract - mkLocalName, mkSysLocalName, mkTopName, - mkDerivedName, mkGlobalName, + mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, + mkTopName, mkIPName, + mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, + mkUnboundName, isUnboundName, + maybeWiredInIdName, maybeWiredInTyConName, - isWiredInName, + isWiredInName, hashName, nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName, - isExportedName, nameSrcLoc, - isLocallyDefinedName, + isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, + maybeUserImportedFrom, + nameSrcLoc, isLocallyDefinedName, isDllName, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + + -- Environment + NameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + addToNameEnv_C, addToNameEnv, addListToNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, + lookupNameEnv, delFromNameEnv, elemNameEnv, -- Provenance Provenance(..), ImportReason(..), pprProvenance, ExportFlag(..), PrintUnqualified, - pprNameProvenance, systemProvenance, + pprNameProvenance, hasBetterProv, -- Class NamedThing and overloaded friends NamedThing(..), - isExported, - getSrcLoc, isLocallyDefined, getOccString + getSrcLoc, isLocallyDefined, getOccString, toRdrName ) where #include "HsVersions.h" @@ -43,12 +53,13 @@ import {-# SOURCE #-} Var ( Id, setIdName ) import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) import OccName -- All of it -import Module -import RdrName ( RdrName, mkRdrQual, mkRdrUnqual ) -import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import Module ( Module, moduleName, pprModule, mkVanillaModule, isLocalModule ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) -import Unique ( pprUnique, Unique, Uniquable(..) ) +import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i ) +import UniqFM import Outputable import GlaExts \end{code} @@ -93,14 +104,36 @@ mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, -- * 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 +mkImportedLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, + n_prov = NonLocalDef ImplicitImport True } + + mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_prov = prov } -mkSysLocalName :: Unique -> FAST_STRING -> Name +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 = SystemProv } + n_occ = mkSrcVarOcc 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 @@ -117,6 +150,14 @@ mkTopName uniq mod fs n_occ = mkSrcVarOcc (_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 = occ, + -- ZZ is this an appropriate provinence? + n_prov = SystemProv } + ------------------------- Wired in names ------------------------- mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name @@ -140,6 +181,16 @@ mkDerivedName :: (OccName -> OccName) mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey +\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. @@ -202,9 +253,7 @@ are exported. But also: \begin{code} tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) tidyTopName mod env name - | isExported name = (env, name) -- Don't fiddle with an exported name - -- It should be in the TidyOccEnv already - | otherwise = (env', name') + = (env', name') where (env', occ') = tidyOccName env (n_occ name) @@ -219,6 +268,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 @@ -354,7 +404,7 @@ nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc isLocallyDefinedName :: Name -> Bool -isExportedName :: Name -> Bool +isUserExportedName :: Name -> Bool isWiredInName :: Name -> Bool isLocalName :: Name -> Bool isGlobalName :: Name -> Bool @@ -362,6 +412,9 @@ isExternallyVisibleName :: Name -> Bool +hashName :: Name -> Int +hashName name = IBOX( u2i (nameUnique name) ) + nameUnique name = n_uniq name nameOccName name = n_occ name @@ -375,17 +428,40 @@ 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 (nameSortModule sort) 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 -isExportedName (Name { n_prov = LocalDef _ Exported }) = True -isExportedName 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) && + not (isLocalModule (nameModule nm)) nameSrcLoc name = provSrcLoc (n_prov name) provSrcLoc (LocalDef loc _) = loc provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc -provSrcLoc SystemProv = noSrcLoc +provSrcLoc other = noSrcLoc isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here @@ -419,6 +495,18 @@ isGlobalName other = True -- does not mean visible at the source level (that's isExported). isExternallyVisibleName name = isGlobalName name +hasBetterProv :: Name -> Name -> Bool +-- 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 \end{code} @@ -440,8 +528,8 @@ instance Eq Name where a /= b = case (a `compare` b) of { EQ -> False; _ -> True } 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 -> 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 @@ -456,6 +544,43 @@ instance NamedThing Name where %************************************************************************ %* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +nameEnvElts :: NameEnv a -> [a] +addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a +addListToNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a + +emptyNameEnv = emptyUFM +nameEnvElts = eltsUFM +addToNameEnv_C = addToUFM_C +addToNameEnv = addToUFM +addListToNameEnv = addListToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnv = addListToUFM +lookupNameEnv = lookupUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM +unitNameEnv = unitUFM +\end{code} + + +%************************************************************************ +%* * \subsection{Pretty printing} %* * %************************************************************************ @@ -497,7 +622,7 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) pp_mod_dot sty = case prov of - SystemProv -> pp_qual mod pp_sep user_sty + SystemProv -> pp_qual mod user_sty -- Hack alert! Omit the qualifier on SystemProv things in user style -- I claim such SystemProv things will also be WiredIn things. -- We can't get the omit flag right @@ -505,24 +630,20 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ, n_prov = prov}) -- and hope that leaving it out isn't too consfusing. -- (e.g. if the programmer hides Bool and redefines it. If so, use -dppr-debug.) - LocalDef _ _ -> pp_qual mod dot (user_sty || iface_sty) + LocalDef _ _ -> pp_qual mod (user_sty || iface_sty) NonLocalDef (UserImport imp_mod _ _) omit - | user_sty -> pp_qual imp_mod pp_sep omit - | otherwise -> pp_qual mod pp_sep False - NonLocalDef ImplicitImport omit -> pp_qual mod pp_sep (user_sty && omit) + | user_sty -> pp_qual imp_mod omit + | otherwise -> pp_qual mod False + NonLocalDef ImplicitImport omit -> pp_qual mod (user_sty && omit) where user_sty = userStyle sty iface_sty = ifaceStyle sty - pp_qual mod sep omit_qual + pp_qual mod omit_qual | omit_qual = empty - | otherwise = pprModule mod <> sep + | otherwise = pprModule mod <> dot - pp_sep | bootFlavour (moduleIfaceFlavour mod) = text "!" -- M!t indicates a name imported - -- from a .hi-boot interface - | otherwise = dot -- Vanilla case - pp_global_debug sty uniq prov | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] | otherwise = empty @@ -556,13 +677,13 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool -isExported :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String +toRdrName :: NamedThing a => a -> RdrName -isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName getOccString x = occNameString (getOccName x) +toRdrName = ifaceNameRdrName . getName \end{code} \begin{code}