compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002-2006
   2
   3 \begin{code}
   4 module IfaceEnv (
   5         newGlobalBinder, newIPName, newImplicitBinder,
   6         lookupIfaceTop,
   7         lookupOrig, lookupOrigNameCache, extendNameCache,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv,
  10         tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
  11         tcIfaceTick,
  12
  13         ifaceExportNames,
  14
  15         -- Name-cache stuff
  16         allocateGlobalBinder, initNameCache,
  17         getNameCache, setNameCache
  18    ) where
  19
  20 #include "HsVersions.h"
  21
  22 import TcRnMonad
  23 import TysWiredIn
  24 import HscTypes
  25 import TyCon
  26 import DataCon
  27 import Var
  28 import Name
  29 import PrelNames
  30 import Module
  31 import LazyUniqFM
  32 import FastString
  33 import UniqSupply
  34 import FiniteMap
  35 import BasicTypes
  36 import SrcLoc
  37 import MkId
  38
  39 import Outputable
  40 \end{code}
  41
  42
  43 %*********************************************************
  44 %*                                                      *
  45         Allocating new Names in the Name Cache
  46 %*                                                      *
  47 %*********************************************************
  48
  49 \begin{code}
  50 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
  51 -- Used for source code and interface files, to make the
  52 -- Name for a thing, given its Module and OccName
  53 --
  54 -- The cache may already already have a binding for this thing,
  55 -- because we may have seen an occurrence before, but now is the
  56 -- moment when we know its Module and SrcLoc in their full glory
  57
  58 newGlobalBinder mod occ loc
  59   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  60 --      ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
  61         ; name_supply <- getNameCache
  62         ; let (name_supply', name) = allocateGlobalBinder
  63                                         name_supply mod occ
  64                                         loc
  65         ; setNameCache name_supply'
  66         ; return name }
  67
  68 allocateGlobalBinder
  69   :: NameCache
  70   -> Module -> OccName -> SrcSpan
  71   -> (NameCache, Name)
  72 allocateGlobalBinder name_supply mod occ loc
  73   = case lookupOrigNameCache (nsNames name_supply) mod occ of
  74         -- A hit in the cache!  We are at the binding site of the name.
  75         -- This is the moment when we know the SrcLoc
  76         -- of the Name, so we set this field in the Name we return.
  77         --
  78         -- Then (bogus) multiple bindings of the same Name
  79         -- get different SrcLocs can can be reported as such.
  80         --
  81         -- Possible other reason: it might be in the cache because we
  82         --      encountered an occurrence before the binding site for an
  83         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  84         --      better... but not really: it'll still just say 'imported'
  85         --
  86         -- IMPORTANT: Don't mess with wired-in names.
  87         --            Their wired-in-ness is in their NameSort
  88         --            and their Module is correct.
  89
  90         Just name | isWiredInName name -> (name_supply, name)
  91                   | otherwise -> (new_name_supply, name')
  92                   where
  93                     uniq      = nameUnique name
  94                     name'     = mkExternalName uniq mod occ loc
  95                     new_cache = extendNameCache (nsNames name_supply) mod occ name'
  96                     new_name_supply = name_supply {nsNames = new_cache}
  97
  98         -- Miss in the cache!
  99         -- Build a completely new Name, and put it in the cache
 100         Nothing -> (new_name_supply, name)
 101                 where
 102                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 103                   uniq            = uniqFromSupply us1
 104                   name            = mkExternalName uniq mod occ loc
 105                   new_cache       = extendNameCache (nsNames name_supply) mod occ name
 106                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 107
 108
 109 newImplicitBinder :: Name                       -- Base name
 110                   -> (OccName -> OccName)       -- Occurrence name modifier
 111                   -> TcRnIf m n Name            -- Implicit name
 112 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 113 -- For source type/class decls, this is the first occurrence
 114 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 115 newImplicitBinder base_name mk_sys_occ
 116   | Just mod <- nameModule_maybe base_name
 117   = newGlobalBinder mod occ loc
 118   | otherwise           -- When typechecking a [d| decl bracket |],
 119                         -- TH generates types, classes etc with Internal names,
 120                         -- so we follow suit for the implicit binders
 121   = do  { uniq <- newUnique
 122         ; return (mkInternalName uniq occ loc) }
 123   where
 124     occ = mk_sys_occ (nameOccName base_name)
 125     loc = nameSrcSpan base_name
 126
 127 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 128 ifaceExportNames exports = do
 129   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
 130   return (concat mod_avails)
 131
 132 -- Convert OccNames in GenAvailInfo to Names.
 133 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
 134 lookupAvail mod (Avail n) = do
 135   n' <- lookupOrig mod n
 136   return (Avail n')
 137 lookupAvail mod (AvailTC p_occ occs) = do
 138   p_name <- lookupOrig mod p_occ
 139   let lookup_sub occ | occ == p_occ = return p_name
 140                      | otherwise    = lookupOrig mod occ
 141   subs <- mapM lookup_sub occs
 142   return (AvailTC p_name subs)
 143         -- Remember that 'occs' is all the exported things, including
 144         -- the parent.  It's possible to export just class ops without
 145         -- the class, which shows up as C( op ) here. If the class was
 146         -- exported too we'd have C( C, op )
 147
 148 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
 149 lookupOrig mod occ
 150   = do  {       -- First ensure that mod and occ are evaluated
 151                 -- If not, chaos can ensue:
 152                 --      we read the name-cache
 153                 --      then pull on mod (say)
 154                 --      which does some stuff that modifies the name cache
 155                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 156           mod `seq` occ `seq` return ()
 157 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
 158
 159         ; name_cache <- getNameCache
 160         ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
 161               Just name -> return name;
 162               Nothing   ->
 163               let
 164                 us        = nsUniqs name_cache
 165                 uniq      = uniqFromSupply us
 166                 name      = mkExternalName uniq mod occ noSrcSpan
 167                 new_cache = extendNameCache (nsNames name_cache) mod occ name
 168               in
 169               case splitUniqSupply us of { (us',_) -> do
 170                 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
 171                 return name
 172     }}}
 173
 174 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 175 newIPName occ_name_ip = do
 176     name_supply <- getNameCache
 177     let
 178         ipcache = nsIPs name_supply
 179     case lookupFM ipcache key of
 180         Just name_ip -> return name_ip
 181         Nothing      -> do setNameCache new_ns
 182                            return name_ip
 183                   where
 184                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 185                      uniq        = uniqFromSupply us1
 186                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 187                      new_ipcache = addToFM ipcache key name_ip
 188                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 189     where
 190         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195                 Name cache access
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 201 lookupOrigNameCache _ mod occ
 202   -- XXX Why is gHC_UNIT not mentioned here?
 203   | mod == gHC_TUPLE || mod == gHC_PRIM,                -- Boxed tuples from one,
 204     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 205   =     -- Special case for tuples; there are too many
 206         -- of them to pre-populate the original-name cache
 207     Just (mk_tup_name tup_info)
 208   where
 209     mk_tup_name (ns, boxity, arity)
 210         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 211         | ns == dataName = dataConName (tupleCon boxity arity)
 212         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 213
 214 lookupOrigNameCache nc mod occ  -- The normal case
 215   = case lookupModuleEnv nc mod of
 216         Nothing      -> Nothing
 217         Just occ_env -> lookupOccEnv occ_env occ
 218
 219 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 220 extendOrigNameCache nc name
 221   = ASSERT2( isExternalName name, ppr name )
 222     extendNameCache nc (nameModule name) (nameOccName name) name
 223
 224 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 225 extendNameCache nc mod occ name
 226   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 227   where
 228     combine occ_env _ = extendOccEnv occ_env occ name
 229
 230 getNameCache :: TcRnIf a b NameCache
 231 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 232                     readMutVar nc_var }
 233
 234 setNameCache :: NameCache -> TcRnIf a b ()
 235 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 236                        writeMutVar nc_var nc }
 237 \end{code}
 238
 239
 240 \begin{code}
 241 initNameCache :: UniqSupply -> [Name] -> NameCache
 242 initNameCache us names
 243   = NameCache { nsUniqs = us,
 244                 nsNames = initOrigNames names,
 245                 nsIPs   = emptyFM }
 246
 247 initOrigNames :: [Name] -> OrigNameCache
 248 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 249 \end{code}
 250
 251
 252
 253 %************************************************************************
 254 %*                                                                      *
 255                 Type variables and local Ids
 256 %*                                                                      *
 257 %************************************************************************
 258
 259 \begin{code}
 260 tcIfaceLclId :: FastString -> IfL Id
 261 tcIfaceLclId occ
 262   = do  { lcl <- getLclEnv
 263         ; case (lookupUFM (if_id_env lcl) occ) of
 264             Just ty_var -> return ty_var
 265             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 266         }
 267
 268 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 269 extendIfaceIdEnv ids thing_inside
 270   = do  { env <- getLclEnv
 271         ; let { id_env' = addListToUFM (if_id_env env) pairs
 272               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 273         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 274
 275
 276 tcIfaceTyVar :: FastString -> IfL TyVar
 277 tcIfaceTyVar occ
 278   = do  { lcl <- getLclEnv
 279         ; case (lookupUFM (if_tv_env lcl) occ) of
 280             Just ty_var -> return ty_var
 281             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 282         }
 283
 284 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
 285 lookupIfaceTyVar occ
 286   = do  { lcl <- getLclEnv
 287         ; return (lookupUFM (if_tv_env lcl) occ) }
 288
 289 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 290 extendIfaceTyVarEnv tyvars thing_inside
 291   = do  { env <- getLclEnv
 292         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 293               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 294         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 295 \end{code}
 296
 297
 298 %************************************************************************
 299 %*                                                                      *
 300                 Getting from RdrNames to Names
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 \begin{code}
 305 lookupIfaceTop :: OccName -> IfL Name
 306 -- Look up a top-level name from the current Iface module
 307 lookupIfaceTop occ
 308   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 309
 310 newIfaceName :: OccName -> IfL Name
 311 newIfaceName occ
 312   = do  { uniq <- newUnique
 313         ; return $! mkInternalName uniq occ noSrcSpan }
 314
 315 newIfaceNames :: [OccName] -> IfL [Name]
 316 newIfaceNames occs
 317   = do  { uniqs <- newUniqueSupply
 318         ; return [ mkInternalName uniq occ noSrcSpan
 319                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 320 \end{code}
 321
 322 %************************************************************************
 323 %*                                                                      *
 324                 (Re)creating tick boxes
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 \begin{code}
 329 tcIfaceTick :: Module -> Int -> IfL Id
 330 tcIfaceTick modName tickNo
 331   = do { uniq <- newUnique
 332        ; return $ mkTickBoxOpId uniq modName tickNo
 333        }
 334 \end{code}
 335
 336