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,
  11
  12         ifaceExportNames,
  13
  14         -- Name-cache stuff
  15         allocateGlobalBinder, initNameCache,
  16         getNameCache, setNameCache
  17    ) where
  18
  19 #include "HsVersions.h"
  20
  21 import TcRnMonad
  22 import TysWiredIn
  23 import HscTypes
  24 import TyCon
  25 import DataCon
  26 import Var
  27 import Name
  28 import OccName
  29 import PrelNames
  30 import Module
  31 import UniqFM
  32 import FastString
  33 import UniqSupply
  34 import FiniteMap
  35 import BasicTypes
  36 import SrcLoc
  37
  38 import Outputable
  39 \end{code}
  40
  41
  42 %*********************************************************
  43 %*                                                      *
  44         Allocating new Names in the Name Cache
  45 %*                                                      *
  46 %*********************************************************
  47
  48 \begin{code}
  49 newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name
  50 -- Used for source code and interface files, to make the
  51 -- Name for a thing, given its Module and OccName
  52 --
  53 -- The cache may already already have a binding for this thing,
  54 -- because we may have seen an occurrence before, but now is the
  55 -- moment when we know its Module and SrcLoc in their full glory
  56
  57 newGlobalBinder mod occ loc
  58   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  59 --      ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
  60         ; name_supply <- getNameCache
  61         ; let (name_supply', name) = allocateGlobalBinder
  62                                         name_supply mod occ
  63                                         loc
  64         ; setNameCache name_supply'
  65         ; return name }
  66
  67 allocateGlobalBinder
  68   :: NameCache
  69   -> Module -> OccName -> SrcLoc
  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   = newGlobalBinder (nameModule base_name)
 116                     (mk_sys_occ (nameOccName base_name))
 117                     (nameSrcLoc base_name)
 118
 119 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 120 ifaceExportNames exports = do
 121   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
 122   return (concat mod_avails)
 123
 124 -- Convert OccNames in GenAvailInfo to Names.
 125 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
 126 lookupAvail mod (Avail n) = do
 127   n' <- lookupOrig mod n
 128   return (Avail n')
 129 lookupAvail mod (AvailTC p_occ occs) = do
 130   p_name <- lookupOrig mod p_occ
 131   let lookup_sub occ | occ == p_occ = return p_name
 132                      | otherwise    = lookupOrig mod occ
 133   subs <- mappM lookup_sub occs
 134   return (AvailTC p_name subs)
 135         -- Remember that 'occs' is all the exported things, including
 136         -- the parent.  It's possible to export just class ops without
 137         -- the class, which shows up as C( op ) here. If the class was
 138         -- exported too we'd have C( C, op )
 139
 140 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
 141 lookupOrig mod occ
 142   = do  {       -- First ensure that mod and occ are evaluated
 143                 -- If not, chaos can ensue:
 144                 --      we read the name-cache
 145                 --      then pull on mod (say)
 146                 --      which does some stuff that modifies the name cache
 147                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 148           mod `seq` occ `seq` return ()
 149 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
 150
 151         ; name_cache <- getNameCache
 152         ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
 153               Just name -> returnM name;
 154               Nothing   ->
 155               let
 156                 us        = nsUniqs name_cache
 157                 uniq      = uniqFromSupply us
 158                 name      = mkExternalName uniq mod occ noSrcLoc
 159                 new_cache = extendNameCache (nsNames name_cache) mod occ name
 160               in
 161               case splitUniqSupply us of { (us',_) -> do
 162                 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
 163                 return name
 164     }}}
 165
 166 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 167 newIPName occ_name_ip
 168   = getNameCache                `thenM` \ name_supply ->
 169     let
 170         ipcache = nsIPs name_supply
 171     in
 172     case lookupFM ipcache key of
 173         Just name_ip -> returnM name_ip
 174         Nothing      -> setNameCache new_ns     `thenM_`
 175                         returnM name_ip
 176                   where
 177                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 178                      uniq        = uniqFromSupply us1
 179                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 180                      new_ipcache = addToFM ipcache key name_ip
 181                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 182     where
 183         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 184 \end{code}
 185
 186         Local helper functions (not exported)
 187
 188 \begin{code}
 189 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 190 lookupOrigNameCache nc mod occ
 191   | mod == dATA_TUP || mod == gHC_PRIM,         -- Boxed tuples from one,
 192     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 193   =     -- Special case for tuples; there are too many
 194         -- of them to pre-populate the original-name cache
 195     Just (mk_tup_name tup_info)
 196   where
 197     mk_tup_name (ns, boxity, arity)
 198         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 199         | ns == dataName = dataConName (tupleCon boxity arity)
 200         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 201
 202 lookupOrigNameCache nc mod occ  -- The normal case
 203   = case lookupModuleEnv nc mod of
 204         Nothing      -> Nothing
 205         Just occ_env -> lookupOccEnv occ_env occ
 206
 207 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 208 extendOrigNameCache nc name
 209   = extendNameCache nc (nameModule name) (nameOccName name) name
 210
 211 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 212 extendNameCache nc mod occ name
 213   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 214   where
 215     combine occ_env _ = extendOccEnv occ_env occ name
 216
 217 getNameCache :: TcRnIf a b NameCache
 218 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 219                     readMutVar nc_var }
 220
 221 setNameCache :: NameCache -> TcRnIf a b ()
 222 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 223                        writeMutVar nc_var nc }
 224 \end{code}
 225
 226
 227 \begin{code}
 228 initNameCache :: UniqSupply -> [Name] -> NameCache
 229 initNameCache us names
 230   = NameCache { nsUniqs = us,
 231                 nsNames = initOrigNames names,
 232                 nsIPs   = emptyFM }
 233
 234 initOrigNames :: [Name] -> OrigNameCache
 235 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 236 \end{code}
 237
 238
 239
 240 %************************************************************************
 241 %*                                                                      *
 242                 Type variables and local Ids
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 \begin{code}
 247 tcIfaceLclId :: FastString -> IfL Id
 248 tcIfaceLclId occ
 249   = do  { lcl <- getLclEnv
 250         ; case (lookupUFM (if_id_env lcl) occ) of
 251             Just ty_var -> return ty_var
 252             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 253         }
 254
 255 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 256 extendIfaceIdEnv ids thing_inside
 257   = do  { env <- getLclEnv
 258         ; let { id_env' = addListToUFM (if_id_env env) pairs
 259               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 260         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 261
 262
 263 tcIfaceTyVar :: FastString -> IfL TyVar
 264 tcIfaceTyVar occ
 265   = do  { lcl <- getLclEnv
 266         ; case (lookupUFM (if_tv_env lcl) occ) of
 267             Just ty_var -> return ty_var
 268             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 269         }
 270
 271 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 272 extendIfaceTyVarEnv tyvars thing_inside
 273   = do  { env <- getLclEnv
 274         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 275               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 276         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282                 Getting from RdrNames to Names
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 lookupIfaceTop :: OccName -> IfL Name
 288 -- Look up a top-level name from the current Iface module
 289 lookupIfaceTop occ
 290   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 291
 292 newIfaceName :: OccName -> IfL Name
 293 newIfaceName occ
 294   = do  { uniq <- newUnique
 295         ; return $! mkInternalName uniq occ noSrcLoc }
 296
 297 newIfaceNames :: [OccName] -> IfL [Name]
 298 newIfaceNames occs
 299   = do  { uniqs <- newUniqueSupply
 300         ; return [ mkInternalName uniq occ noSrcLoc
 301                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 302 \end{code}