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 UniqFM
  32 import FastString
  33 import UniqSupply
  34 import BasicTypes
  35 import SrcLoc
  36 import MkId
  37
  38 import Outputable
  39 import Exception     ( evaluate )
  40
  41 import Data.IORef    ( atomicModifyIORef, readIORef )
  42 import qualified Data.Map as Map
  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                   (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
 102                   name            = mkExternalName uniq mod occ loc
 103                   new_cache       = extendNameCache (nsNames name_supply) mod occ name
 104                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 105
 106
 107 newImplicitBinder :: Name                       -- Base name
 108                   -> (OccName -> OccName)       -- Occurrence name modifier
 109                   -> TcRnIf m n Name            -- Implicit name
 110 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 111 -- For source type/class decls, this is the first occurrence
 112 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 113 newImplicitBinder base_name mk_sys_occ
 114   | Just mod <- nameModule_maybe base_name
 115   = newGlobalBinder mod occ loc
 116   | otherwise           -- When typechecking a [d| decl bracket |],
 117                         -- TH generates types, classes etc with Internal names,
 118                         -- so we follow suit for the implicit binders
 119   = do  { uniq <- newUnique
 120         ; return (mkInternalName uniq occ loc) }
 121   where
 122     occ = mk_sys_occ (nameOccName base_name)
 123     loc = nameSrcSpan base_name
 124
 125 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 126 ifaceExportNames exports = do
 127   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
 128   return (concat mod_avails)
 129
 130 -- Convert OccNames in GenAvailInfo to Names.
 131 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
 132 lookupAvail mod (Avail n) = do
 133   n' <- lookupOrig mod n
 134   return (Avail n')
 135 lookupAvail mod (AvailTC p_occ occs) = do
 136   p_name <- lookupOrig mod p_occ
 137   let lookup_sub occ | occ == p_occ = return p_name
 138                      | otherwise    = lookupOrig mod occ
 139   subs <- mapM lookup_sub occs
 140   return (AvailTC p_name subs)
 141         -- Remember that 'occs' is all the exported things, including
 142         -- the parent.  It's possible to export just class ops without
 143         -- the class, which shows up as C( op ) here. If the class was
 144         -- exported too we'd have C( C, op )
 145
 146 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
 147 lookupOrig mod occ
 148   = do  {       -- First ensure that mod and occ are evaluated
 149                 -- If not, chaos can ensue:
 150                 --      we read the name-cache
 151                 --      then pull on mod (say)
 152                 --      which does some stuff that modifies the name cache
 153                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 154           mod `seq` occ `seq` return ()
 155 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
 156
 157         ; updNameCache $ \name_cache ->
 158             case lookupOrigNameCache (nsNames name_cache) mod occ of {
 159               Just name -> (name_cache, name);
 160               Nothing   ->
 161               case takeUniqFromSupply (nsUniqs name_cache) of {
 162               (uniq, us) ->
 163                   let
 164                     name      = mkExternalName uniq mod occ noSrcSpan
 165                     new_cache = extendNameCache (nsNames name_cache) mod occ name
 166                   in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
 167     }}}
 168
 169 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 170 newIPName occ_name_ip =
 171   updNameCache $ \name_cache ->
 172     let
 173         ipcache = nsIPs name_cache
 174         key = occ_name_ip  -- Ensures that ?x and %x get distinct Names
 175     in
 176     case Map.lookup key ipcache of
 177       Just name_ip -> (name_cache, name_ip)
 178       Nothing      -> (new_ns, name_ip)
 179           where
 180             (uniq, us') = takeUniqFromSupply (nsUniqs name_cache)
 181             name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 182             new_ipcache = Map.insert key name_ip ipcache
 183             new_ns      = name_cache {nsUniqs = us', nsIPs = new_ipcache}
 184 \end{code}
 185
 186 %************************************************************************
 187 %*                                                                      *
 188                 Name cache access
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 \begin{code}
 193 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 194 lookupOrigNameCache _ mod occ
 195   -- XXX Why is gHC_UNIT not mentioned here?
 196   | mod == gHC_TUPLE || mod == gHC_PRIM,                -- Boxed tuples from one,
 197     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 198   =     -- Special case for tuples; there are too many
 199         -- of them to pre-populate the original-name cache
 200     Just (mk_tup_name tup_info)
 201   where
 202     mk_tup_name (ns, boxity, arity)
 203         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 204         | ns == dataName = dataConName (tupleCon boxity arity)
 205         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 206
 207 lookupOrigNameCache nc mod occ  -- The normal case
 208   = case lookupModuleEnv nc mod of
 209         Nothing      -> Nothing
 210         Just occ_env -> lookupOccEnv occ_env occ
 211
 212 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 213 extendOrigNameCache nc name
 214   = ASSERT2( isExternalName name, ppr name )
 215     extendNameCache nc (nameModule name) (nameOccName name) name
 216
 217 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 218 extendNameCache nc mod occ name
 219   = extendModuleEnvWith combine nc mod (unitOccEnv occ name)
 220   where
 221     combine _ occ_env = extendOccEnv occ_env occ name
 222
 223 getNameCache :: TcRnIf a b NameCache
 224 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 225                     readMutVar nc_var }
 226
 227 updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
 228 updNameCache upd_fn = do
 229   HscEnv { hsc_NC = nc_var } <- getTopEnv
 230   atomicUpdMutVar' nc_var upd_fn
 231
 232 -- | A function that atomically updates the name cache given a modifier
 233 -- function.  The second result of the modifier function will be the result
 234 -- of the IO action.
 235 type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c
 236
 237 -- | Return a function to atomically update the name cache.
 238 mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
 239 mkNameCacheUpdater = do
 240   nc_var <- hsc_NC `fmap` getTopEnv
 241   let update_nc f = do r <- atomicModifyIORef nc_var f
 242                        _ <- evaluate =<< readIORef nc_var
 243                        return r
 244   return update_nc
 245 \end{code}
 246
 247
 248 \begin{code}
 249 initNameCache :: UniqSupply -> [Name] -> NameCache
 250 initNameCache us names
 251   = NameCache { nsUniqs = us,
 252                 nsNames = initOrigNames names,
 253                 nsIPs   = Map.empty }
 254
 255 initOrigNames :: [Name] -> OrigNameCache
 256 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 257 \end{code}
 258
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263                 Type variables and local Ids
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 tcIfaceLclId :: FastString -> IfL Id
 269 tcIfaceLclId occ
 270   = do  { lcl <- getLclEnv
 271         ; case (lookupUFM (if_id_env lcl) occ) of
 272             Just ty_var -> return ty_var
 273             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 274         }
 275
 276 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 277 extendIfaceIdEnv ids thing_inside
 278   = do  { env <- getLclEnv
 279         ; let { id_env' = addListToUFM (if_id_env env) pairs
 280               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 281         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 282
 283
 284 tcIfaceTyVar :: FastString -> IfL TyVar
 285 tcIfaceTyVar occ
 286   = do  { lcl <- getLclEnv
 287         ; case (lookupUFM (if_tv_env lcl) occ) of
 288             Just ty_var -> return ty_var
 289             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 290         }
 291
 292 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
 293 lookupIfaceTyVar occ
 294   = do  { lcl <- getLclEnv
 295         ; return (lookupUFM (if_tv_env lcl) occ) }
 296
 297 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 298 extendIfaceTyVarEnv tyvars thing_inside
 299   = do  { env <- getLclEnv
 300         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 301               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 302         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308                 Getting from RdrNames to Names
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 lookupIfaceTop :: OccName -> IfL Name
 314 -- Look up a top-level name from the current Iface module
 315 lookupIfaceTop occ
 316   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 317
 318 newIfaceName :: OccName -> IfL Name
 319 newIfaceName occ
 320   = do  { uniq <- newUnique
 321         ; return $! mkInternalName uniq occ noSrcSpan }
 322
 323 newIfaceNames :: [OccName] -> IfL [Name]
 324 newIfaceNames occs
 325   = do  { uniqs <- newUniqueSupply
 326         ; return [ mkInternalName uniq occ noSrcSpan
 327                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332                 (Re)creating tick boxes
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 tcIfaceTick :: Module -> Int -> IfL Id
 338 tcIfaceTick modName tickNo
 339   = do { uniq <- newUnique
 340        ; return $ mkTickBoxOpId uniq modName tickNo
 341        }
 342 \end{code}
 343
 344