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