X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FName.lhs;h=af9f2809ad69f602276597b4d255db991d29e52d;hp=3684a70306e9c3a3950c8ee3dcee316bb72f7844;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 3684a70..af9f280 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Name]{@Name@: to transmit name info from renamer to typechecker} @@ -14,6 +15,7 @@ module Name ( mkInternalName, mkSystemName, mkSystemVarName, mkSysTvName, mkFCallName, mkIPName, + mkTickBoxOpName, mkExternalName, mkWiredInName, nameUnique, setNameUnique, @@ -21,29 +23,36 @@ module Name ( tidyNameOcc, hashName, localiseName, - nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, + nameSrcLoc, nameSrcSpan, isSystemName, isInternalName, isExternalName, - isTyVarName, isWiredInName, isBuiltInSyntax, + isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax, wiredInNameTyThing_maybe, nameIsLocalOrFrom, -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString + getSrcLoc, getSrcSpan, getOccString ) where #include "HsVersions.h" import {-# SOURCE #-} TypeRep( TyThing ) -import OccName -- All of it -import Module ( Module ) -import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) -import Unique ( Unique, Uniquable(..), getKey, pprUnique ) -import Maybes ( orElse, isJust ) -import FastString ( FastString, zEncodeFS ) +import OccName +import Module +import SrcLoc +import UniqFM +import Unique +import Maybes +import Binary +import FastMutInt +import FastString import Outputable + +import Data.IORef +import GHC.Exts +import Data.Array \end{code} %************************************************************************ @@ -56,8 +65,8 @@ import Outputable data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name - n_uniq :: {-# UNPACK #-} !Unique, - n_loc :: !SrcLoc -- Definition site + n_uniq :: Int#, -- UNPACK doesn't work, recursive type + n_loc :: !SrcSpan -- Definition site } -- NOTE: we make the n_loc field strict to eliminate some potential @@ -65,12 +74,9 @@ data Name = Name { -- the SrcLoc in a Name all that often. data NameSort - = External Module (Maybe Name) - -- (Just parent) => this Name is a subordinate name of 'parent' - -- e.g. data constructor of a data type, method of a class - -- Nothing => not a subordinate + = External Module - | WiredIn Module (Maybe Name) TyThing BuiltInSyntax + | WiredIn Module TyThing BuiltInSyntax -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar @@ -121,10 +127,12 @@ nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan -nameUnique name = n_uniq name +nameUnique name = mkUniqueGrimily (I# (n_uniq name)) nameOccName name = n_occ name -nameSrcLoc name = n_loc name +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name \end{code} \begin{code} @@ -134,41 +142,26 @@ isExternalName :: Name -> Bool isSystemName :: Name -> Bool isWiredInName :: Name -> Bool -isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True -isWiredInName other = False +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName other = False wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing _}) = Just thing -wiredInNameTyThing_maybe other = Nothing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe other = Nothing -isBuiltInSyntax (Name {n_sort = WiredIn _ _ _ BuiltInSyntax}) = True -isBuiltInSyntax other = False +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax other = False -isExternalName (Name {n_sort = External _ _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _ _}) = True -isExternalName other = False +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName other = False isInternalName name = not (isExternalName name) -nameParent_maybe :: Name -> Maybe Name -nameParent_maybe (Name {n_sort = External _ p}) = p -nameParent_maybe (Name {n_sort = WiredIn _ p _ _}) = p -nameParent_maybe other = Nothing - -nameParent :: Name -> Name -nameParent name = case nameParent_maybe name of - Just parent -> parent - Nothing -> name - -isImplicitName :: Name -> Bool --- An Implicit Name is one has a parent; that is, one whose definition --- derives from the parent thing -isImplicitName name = isJust (nameParent_maybe name) - nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) -nameModule_maybe (Name { n_sort = External mod _}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod -nameModule_maybe name = Nothing +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe name = Nothing nameIsLocalOrFrom from name | isExternalName name = from == nameModule name @@ -177,6 +170,9 @@ nameIsLocalOrFrom from name isTyVarName :: Name -> Bool isTyVarName name = isTvOcc (nameOccName name) +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + isSystemName (Name {n_sort = System}) = True isSystemName other = False \end{code} @@ -189,8 +185,8 @@ isSystemName other = False %************************************************************************ \begin{code} -mkInternalName :: Unique -> OccName -> SrcLoc -> Name -mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = occ, n_loc = loc } +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, 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 @@ -200,21 +196,21 @@ mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = o -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name -mkExternalName uniq mod occ mb_parent loc - = Name { n_uniq = uniq, n_sort = External mod mb_parent, +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +mkExternalName uniq mod occ loc + = Name { n_uniq = getKey# uniq, n_sort = External mod, n_occ = occ, n_loc = loc } -mkWiredInName :: Module -> OccName -> Unique - -> Maybe Name -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq mb_parent thing built_in - = Name { n_uniq = uniq, - n_sort = WiredIn mod mb_parent thing built_in, - n_occ = occ, n_loc = wiredInSrcLoc } +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax + -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = getKey# uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = Name { n_uniq = uniq, n_sort = System, - n_occ = occ, n_loc = noSrcLoc } +mkSystemName uniq occ = Name { n_uniq = getKey# uniq, n_sort = System, + n_occ = occ, n_loc = noSrcSpan } mkSystemVarName :: Unique -> FastString -> Name mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) @@ -224,22 +220,28 @@ mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) mkFCallName :: Unique -> String -> Name -- The encoded string completely describes the ccall -mkFCallName uniq str = Name { n_uniq = uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcLoc } +mkFCallName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal, + n_occ = mkVarOcc str, n_loc = noSrcSpan } + +mkTickBoxOpName :: Unique -> String -> Name +mkTickBoxOpName uniq str + = Name { n_uniq = getKey# uniq, n_sort = Internal, + n_occ = mkVarOcc str, n_loc = noSrcSpan } mkIPName :: Unique -> OccName -> Name mkIPName uniq occ - = Name { n_uniq = uniq, + = Name { n_uniq = getKey# uniq, n_sort = Internal, n_occ = occ, - n_loc = noSrcLoc } + n_loc = noSrcSpan } \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. -setNameUnique name uniq = name {n_uniq = uniq} +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = getKey# uniq} tidyNameOcc :: Name -> OccName -> Name -- We set the OccName of a Name when tidying @@ -260,8 +262,11 @@ localiseName n = n { n_sort = Internal } %************************************************************************ \begin{code} -hashName :: Name -> Int -hashName name = getKey (nameUnique name) +hashName :: Name -> Int -- ToDo: should really be Word +hashName name = getKey (nameUnique name) + 1 + -- The +1 avoids keys with lots of zeros in the ls bits, which + -- interacts badly with the cheap and cheerful multiplication in + -- hashExpr \end{code} @@ -272,7 +277,7 @@ hashName name = getKey (nameUnique name) %************************************************************************ \begin{code} -cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 +cmpName n1 n2 = I# (n_uniq n1) `compare` I# (n_uniq n2) \end{code} \begin{code} @@ -294,6 +299,33 @@ instance NamedThing Name where getName n = n \end{code} +%************************************************************************ +%* * +\subsection{Binary} +%* * +%************************************************************************ + +\begin{code} +instance Binary Name where + put_ bh name = do + case getUserData bh of { + UserData { ud_symtab_map = symtab_map_ref, + ud_symtab_next = symtab_next } -> do + symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh off + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh off + } + + get bh = do + i <- get bh + return $! (ud_symtab (getUserData bh) ! i) +\end{code} %************************************************************************ %* * @@ -308,13 +340,14 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name -pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) +pprName name@(Name {n_sort = sort, n_uniq = u#, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - WiredIn mod _ _ builtin -> pprExternal sty uniq mod occ True builtin - External mod _ -> pprExternal sty uniq mod occ False UserSyntax + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ + where uniq = mkUniqueGrimily (I# u#) pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ @@ -375,9 +408,11 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan getOccString :: NamedThing a => a -> String getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName \end{code}