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