ghc/compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002
   2
   3 \begin{code}
   4 module IfaceEnv (
   5         newGlobalBinder, newIPName, newImplicitBinder,
   6         lookupIfaceTop, lookupIfaceExt,
   7         lookupOrig, lookupIfaceTc,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv,
  10         tcIfaceLclId,     tcIfaceTyVar,
  11
  12         -- Name-cache stuff
  13         allocateGlobalBinder, initNameCache
  14    ) where
  15
  16 #include "HsVersions.h"
  17
  18 import TcRnMonad
  19 import IfaceType        ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
  20 import TysWiredIn       ( tupleTyCon, tupleCon )
  21 import HscTypes         ( NameCache(..), HscEnv(..),
  22                           TyThing, ExternalPackageState(..), OrigNameCache )
  23 import TyCon            ( TyCon, tyConName )
  24 import Class            ( Class )
  25 import DataCon          ( dataConWorkId, dataConName )
  26 import Var              ( TyVar, Id, varName )
  27 import Name             ( Name, nameUnique, nameModule,
  28                           nameOccName, nameSrcLoc,
  29                           getOccName, nameParent_maybe,
  30                           isWiredInName, mkIPName,
  31                           mkExternalName, mkInternalName )
  32 import NameEnv
  33 import OccName          ( OccName, isTupleOcc_maybe, tcName, dataName,
  34                           lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
  35 import PrelNames        ( gHC_PRIM_Name, pREL_TUP_Name )
  36 import HscTypes         ( ExternalPackageState, NameCache, TyThing(..) )
  37 import Module           ( Module, ModuleName, moduleName, mkPackageModule,
  38                           emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
  39 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
  40 import FiniteMap        ( emptyFM, lookupFM, addToFM )
  41 import BasicTypes       ( IPName(..), mapIPName )
  42 import SrcLoc           ( SrcLoc, noSrcLoc )
  43 import Maybes           ( orElse )
  44
  45 import Outputable
  46 \end{code}
  47
  48
  49 %*********************************************************
  50 %*                                                      *
  51         Allocating new Names in the Name Cache
  52 %*                                                      *
  53 %*********************************************************
  54
  55 \begin{code}
  56 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
  57 -- Used for source code and interface files, to make the
  58 -- Name for a thing, given its Module and OccName
  59 --
  60 -- The cache may already already have a binding for this thing,
  61 -- because we may have seen an occurrence before, but now is the
  62 -- moment when we know its Module and SrcLoc in their full glory
  63
  64 newGlobalBinder mod occ mb_parent loc
  65   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  66         ; name_supply <- getNameCache
  67         ; let (name_supply', name) = allocateGlobalBinder
  68                                         name_supply mod occ
  69                                         mb_parent loc
  70         ; setNameCache name_supply'
  71         ; return name }
  72
  73 allocateGlobalBinder
  74   :: NameCache
  75   -> Module -> OccName -> Maybe Name -> SrcLoc
  76   -> (NameCache, Name)
  77 allocateGlobalBinder name_supply mod occ mb_parent loc
  78   = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of
  79         -- A hit in the cache!  We are at the binding site of the name.
  80         -- This is the moment when we know the defining Module and SrcLoc
  81         -- of the Name, so we set these fields in the Name we return.
  82         --
  83         -- This is essential, to get the right Module in a Name.
  84         -- Also: then (bogus) multiple bindings of the same Name
  85         --              get different SrcLocs can can be reported as such.
  86         --
  87         -- Possible other reason: it might be in the cache because we
  88         --      encountered an occurrence before the binding site for an
  89         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  90         --      better... but not really: it'll still just say 'imported'
  91         --
  92         -- IMPORTANT: Don't mess with wired-in names.
  93         --            Their wired-in-ness is in their NameSort
  94         --            and their Module is correct.
  95
  96         Just name | isWiredInName name -> (name_supply, name)
  97                   | otherwise -> (new_name_supply, name')
  98                   where
  99                     uniq      = nameUnique name
 100                     name'     = mkExternalName uniq mod occ mb_parent loc
 101                     new_cache = extend_name_cache (nsNames name_supply) mod occ name'
 102                     new_name_supply = name_supply {nsNames = new_cache}
 103
 104         -- Miss in the cache!
 105         -- Build a completely new Name, and put it in the cache
 106         Nothing -> (new_name_supply, name)
 107                 where
 108                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 109                   uniq            = uniqFromSupply us1
 110                   name            = mkExternalName uniq mod occ mb_parent loc
 111                   new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 112                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 113
 114
 115 newImplicitBinder :: Name                       -- Base name
 116                   -> (OccName -> OccName)       -- Occurrence name modifier
 117                   -> TcRnIf m n Name            -- Implicit name
 118 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 119 -- For source type/class decls, this is the first occurrence
 120 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 121 --
 122 -- An *implicit* name has the base-name as parent
 123 newImplicitBinder base_name mk_sys_occ
 124   = newGlobalBinder (nameModule base_name)
 125                     (mk_sys_occ (nameOccName base_name))
 126                     (Just parent_name)
 127                     (nameSrcLoc base_name)
 128   where
 129     parent_name = case nameParent_maybe base_name of
 130                     Just parent_name  -> parent_name
 131                     Nothing           -> base_name
 132
 133 lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
 134 -- This one starts with a ModuleName, not a Module, because
 135 -- we may be simply looking at an occurrence M.x in an interface file.
 136 -- We may enounter this well before finding the binding site for M.x
 137 --
 138 -- So, even if we get a miss in the original-name cache, we
 139 -- make a new External Name.
 140 -- We fake up
 141 --      Module to AnotherPackage
 142 --      SrcLoc to noSrcLoc
 143 --      Parent no Nothing
 144 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
 145
 146 lookupOrig mod_name occ
 147   = do  {       -- First ensure that mod_name and occ are evaluated
 148                 -- If not, chaos can ensue:
 149                 --      we read the name-cache
 150                 --      then pull on mod (say)
 151                 --      which does some stuff that modifies the name cache
 152                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 153           mod `seq` occ `seq` return ()
 154
 155         ; name_supply <- getNameCache
 156         ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
 157               Just name -> returnM name ;
 158               Nothing   -> do
 159
 160         { let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 161               ; uniq            = uniqFromSupply us1
 162               ; name            = mkExternalName uniq tmp_mod occ Nothing noSrcLoc
 163               ; new_cache       = extend_name_cache (nsNames name_supply) tmp_mod occ name
 164               ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 165               ; tmp_mod         = mkPackageModule mod_name
 166                         -- Guess at the package-ness for now, becuase we don't know whether
 167                         -- this imported module is from the home package or not.
 168                         -- If we ever need it, we'll open its interface, and update the cache
 169                         -- with a better name (newGlobalBinder)
 170           }
 171         ; setNameCache new_name_supply
 172         ; return name }
 173     }}
 174
 175 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 176 newIPName occ_name_ip
 177   = getNameCache                `thenM` \ name_supply ->
 178     let
 179         ipcache = nsIPs name_supply
 180     in
 181     case lookupFM ipcache key of
 182         Just name_ip -> returnM name_ip
 183         Nothing      -> setNameCache new_ns     `thenM_`
 184                         returnM name_ip
 185                   where
 186                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 187                      uniq        = uniqFromSupply us1
 188                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 189                      new_ipcache = addToFM ipcache key name_ip
 190                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 191     where
 192         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 193 \end{code}
 194
 195         Local helper functions (not exported)
 196
 197 \begin{code}
 198 lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name
 199 lookupOrigNameCache nc mod_name occ
 200   | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name,     -- Boxed tuples from one,
 201     Just tup_info <- isTupleOcc_maybe occ                       -- unboxed from the other
 202   =     -- Special case for tuples; there are too many
 203         -- of them to pre-populate the original-name cache
 204     Just (mk_tup_name tup_info)
 205   where
 206     mk_tup_name (ns, boxity, arity)
 207         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 208         | ns == dataName = dataConName (tupleCon boxity arity)
 209         | otherwise      = varName (dataConWorkId (tupleCon boxity arity))
 210
 211 lookupOrigNameCache nc mod_name occ     -- The normal case
 212   = case lookupModuleEnvByName nc mod_name of
 213         Nothing      -> Nothing
 214         Just occ_env -> lookupOccEnv occ_env occ
 215
 216 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 217 extendOrigNameCache nc name
 218   = extend_name_cache nc (nameModule name) (nameOccName name) name
 219
 220 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 221 extend_name_cache nc mod occ name
 222   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 223   where
 224     combine occ_env _ = extendOccEnv occ_env occ name
 225
 226 getNameCache :: TcRnIf a b NameCache
 227 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 228                     readMutVar nc_var }
 229
 230 setNameCache :: NameCache -> TcRnIf a b ()
 231 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 232                        writeMutVar nc_var nc }
 233 \end{code}
 234
 235
 236 \begin{code}
 237 initNameCache :: UniqSupply -> [Name] -> NameCache
 238 initNameCache us names
 239   = NameCache { nsUniqs = us,
 240                 nsNames = initOrigNames names,
 241                 nsIPs   = emptyFM }
 242
 243 initOrigNames :: [Name] -> OrigNameCache
 244 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 245 \end{code}
 246
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251                 Type variables and local Ids
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 tcIfaceLclId :: OccName -> IfL Id
 257 tcIfaceLclId occ
 258   = do  { lcl <- getLclEnv
 259         ; return (lookupOccEnv (if_id_env lcl) occ
 260                   `orElse`
 261                   pprPanic "tcIfaceLclId" (ppr occ)) }
 262
 263 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 264 extendIfaceIdEnv ids thing_inside
 265   = do  { env <- getLclEnv
 266         ; let { id_env' = extendOccEnvList (if_id_env env) pairs
 267               ; pairs   = [(getOccName id, id) | id <- ids] }
 268         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 269
 270
 271 tcIfaceTyVar :: OccName -> IfL TyVar
 272 tcIfaceTyVar occ
 273   = do  { lcl <- getLclEnv
 274         ; return (lookupOccEnv (if_tv_env lcl) occ
 275                   `orElse`
 276                   pprPanic "tcIfaceTyVar" (ppr occ)) }
 277
 278 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 279 extendIfaceTyVarEnv tyvars thing_inside
 280   = do  { env <- getLclEnv
 281         ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
 282               ; pairs   = [(getOccName tv, tv) | tv <- tyvars] }
 283         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 284 \end{code}
 285
 286
 287 %************************************************************************
 288 %*                                                                      *
 289                 Getting from RdrNames to Names
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 \begin{code}
 294 lookupIfaceTc :: IfaceTyCon -> IfL Name
 295 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 296 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 297
 298 lookupIfaceExt :: IfaceExtName -> IfL Name
 299 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 300 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 301 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 302 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 303
 304 lookupIfaceTop :: OccName -> IfL Name
 305 -- Look up a top-level name from the current Iface module
 306 lookupIfaceTop occ
 307   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 308
 309 newIfaceName :: OccName -> IfL Name
 310 newIfaceName occ
 311   = do  { uniq <- newUnique
 312         ; return (mkInternalName uniq occ noSrcLoc) }
 313
 314 newIfaceNames :: [OccName] -> IfL [Name]
 315 newIfaceNames occs
 316   = do  { uniqs <- newUniqueSupply
 317         ; return [ mkInternalName uniq occ noSrcLoc
 318                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 319 \end{code}