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, lockedUpdNameCache,
  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     ( onException )
  41
  42 import Control.Concurrent.MVar ( tryTakeMVar, takeMVar, putMVar )
  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 -- | Update the name cache, but takes a lock while the update function is
 237 -- running.  If the update function throws an exception the lock is released
 238 -- and the exception propagated.
 239 lockedUpdNameCache :: (NameCache -> IO (NameCache, c)) -> TcRnIf a b c
 240 lockedUpdNameCache upd_fn = do
 241   lock <- hsc_NC_lock `fmap` getTopEnv
 242   -- Non-blocking "takeMVar" so we can show diagnostics if we didn't get the
 243   -- lock.
 244   mb_ok <- liftIO $ tryTakeMVar lock
 245   case mb_ok of
 246     Nothing -> do
 247       traceIf (text "lockedUpdNameCache: failed to take lock.  blocking..")
 248       _ <- liftIO $ takeMVar lock
 249       traceIf (text "lockedUpdNameCache: got lock")
 250     Just _ -> return ()
 251
 252   name_cache <- getNameCache
 253   (name_cache', rslt) <- liftIO (upd_fn name_cache
 254                                    `onException` putMVar lock ())
 255
 256   nc_var <- hsc_NC `fmap` getTopEnv
 257   writeMutVar nc_var $! name_cache'
 258
 259   liftIO (putMVar lock ())
 260   return rslt
 261 \end{code}
 262
 263
 264 \begin{code}
 265 initNameCache :: UniqSupply -> [Name] -> NameCache
 266 initNameCache us names
 267   = NameCache { nsUniqs = us,
 268                 nsNames = initOrigNames names,
 269                 nsIPs   = emptyFM }
 270
 271 initOrigNames :: [Name] -> OrigNameCache
 272 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 273 \end{code}
 274
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279                 Type variables and local Ids
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 tcIfaceLclId :: FastString -> IfL Id
 285 tcIfaceLclId occ
 286   = do  { lcl <- getLclEnv
 287         ; case (lookupUFM (if_id_env lcl) occ) of
 288             Just ty_var -> return ty_var
 289             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 290         }
 291
 292 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 293 extendIfaceIdEnv ids thing_inside
 294   = do  { env <- getLclEnv
 295         ; let { id_env' = addListToUFM (if_id_env env) pairs
 296               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 297         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 298
 299
 300 tcIfaceTyVar :: FastString -> IfL TyVar
 301 tcIfaceTyVar occ
 302   = do  { lcl <- getLclEnv
 303         ; case (lookupUFM (if_tv_env lcl) occ) of
 304             Just ty_var -> return ty_var
 305             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 306         }
 307
 308 lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
 309 lookupIfaceTyVar occ
 310   = do  { lcl <- getLclEnv
 311         ; return (lookupUFM (if_tv_env lcl) occ) }
 312
 313 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 314 extendIfaceTyVarEnv tyvars thing_inside
 315   = do  { env <- getLclEnv
 316         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 317               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 318         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324                 Getting from RdrNames to Names
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 \begin{code}
 329 lookupIfaceTop :: OccName -> IfL Name
 330 -- Look up a top-level name from the current Iface module
 331 lookupIfaceTop occ
 332   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 333
 334 newIfaceName :: OccName -> IfL Name
 335 newIfaceName occ
 336   = do  { uniq <- newUnique
 337         ; return $! mkInternalName uniq occ noSrcSpan }
 338
 339 newIfaceNames :: [OccName] -> IfL [Name]
 340 newIfaceNames occs
 341   = do  { uniqs <- newUniqueSupply
 342         ; return [ mkInternalName uniq occ noSrcSpan
 343                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348                 (Re)creating tick boxes
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 tcIfaceTick :: Module -> Int -> IfL Id
 354 tcIfaceTick modName tickNo
 355   = do { uniq <- newUnique
 356        ; return $ mkTickBoxOpId uniq modName tickNo
 357        }
 358 \end{code}
 359
 360