ghc/compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002
   2
   3 \begin{code}
   4 module IfaceEnv (
   5         newGlobalBinder, newIPName, newImplicitBinder,
   6         lookupIfaceTop, lookupIfaceExt,
   7         lookupOrig, lookupAvail, lookupIfaceTc,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv,
  10         tcIfaceLclId,     tcIfaceTyVar,
  11
  12         -- Name-cache stuff
  13         allocateGlobalBinder, initNameCache,
  14    ) where
  15
  16 #include "HsVersions.h"
  17
  18 import TcRnMonad
  19 import IfaceType        ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
  20 import TysWiredIn       ( tupleTyCon, tupleCon )
  21 import HscTypes         ( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache )
  22 import TyCon            ( TyCon, tyConName )
  23 import DataCon          ( dataConWorkId, dataConName )
  24 import Var              ( TyVar, Id, varName )
  25 import Name             ( Name, nameUnique, nameModule,
  26                           nameOccName, nameSrcLoc,
  27                           getOccName, nameParent_maybe,
  28                           isWiredInName, mkIPName,
  29                           mkExternalName, mkInternalName )
  30
  31 import OccName          ( OccName, isTupleOcc_maybe, tcName, dataName,
  32                           lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
  33 import PrelNames        ( gHC_PRIM, pREL_TUP )
  34 import Module           ( Module, emptyModuleEnv,
  35                           lookupModuleEnv, extendModuleEnv_C )
  36 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
  37 import FiniteMap        ( emptyFM, lookupFM, addToFM )
  38 import BasicTypes       ( IPName(..), mapIPName )
  39 import SrcLoc           ( SrcLoc, noSrcLoc )
  40 import Maybes           ( orElse )
  41
  42 import Outputable
  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 -> Maybe Name -> SrcLoc -> 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 mb_parent loc
  62   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  63         ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
  64         ; name_supply <- getNameCache
  65         ; let (name_supply', name) = allocateGlobalBinder
  66                                         name_supply mod occ
  67                                         mb_parent loc
  68         ; setNameCache name_supply'
  69         ; return name }
  70
  71 allocateGlobalBinder
  72   :: NameCache
  73   -> Module -> OccName -> Maybe Name -> SrcLoc
  74   -> (NameCache, Name)
  75 allocateGlobalBinder name_supply mod occ mb_parent loc
  76   = case lookupOrigNameCache (nsNames name_supply) mod occ of
  77         -- A hit in the cache!  We are at the binding site of the name.
  78         -- This is the moment when we know the defining parent and SrcLoc
  79         -- of the Name, so we set these fields in the Name we return.
  80         --
  81         -- Then (bogus) multiple bindings of the same Name
  82         -- get different SrcLocs can can be reported as such.
  83         --
  84         -- Possible other reason: it might be in the cache because we
  85         --      encountered an occurrence before the binding site for an
  86         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  87         --      better... but not really: it'll still just say 'imported'
  88         --
  89         -- IMPORTANT: Don't mess with wired-in names.
  90         --            Their wired-in-ness is in their NameSort
  91         --            and their Module is correct.
  92
  93         Just name | isWiredInName name -> (name_supply, name)
  94                   | otherwise -> (new_name_supply, name')
  95                   where
  96                     uniq      = nameUnique name
  97                     name'     = mkExternalName uniq mod occ mb_parent loc
  98                     new_cache = extend_name_cache (nsNames name_supply) mod occ name'
  99                     new_name_supply = name_supply {nsNames = new_cache}
 100
 101         -- Miss in the cache!
 102         -- Build a completely new Name, and put it in the cache
 103         Nothing -> (new_name_supply, name)
 104                 where
 105                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 106                   uniq            = uniqFromSupply us1
 107                   name            = mkExternalName uniq mod occ mb_parent loc
 108                   new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 109                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 110
 111
 112 newImplicitBinder :: Name                       -- Base name
 113                   -> (OccName -> OccName)       -- Occurrence name modifier
 114                   -> TcRnIf m n Name            -- Implicit name
 115 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 116 -- For source type/class decls, this is the first occurrence
 117 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 118 --
 119 -- An *implicit* name has the base-name as parent
 120 newImplicitBinder base_name mk_sys_occ
 121   = newGlobalBinder (nameModule base_name)
 122                     (mk_sys_occ (nameOccName base_name))
 123                     (Just parent_name)
 124                     (nameSrcLoc base_name)
 125   where
 126     parent_name = case nameParent_maybe base_name of
 127                     Just parent_name  -> parent_name
 128                     Nothing           -> base_name
 129
 130 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
 131 -- Find all the names arising from an import
 132 -- Make sure the parent info is correct, even though we may not
 133 -- yet have read the interface for this module
 134 lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n;
 135                                ; return [n'] }
 136 lookupAvail mod (AvailTC p_occ occs)
 137   = do { p_name <- lookupOrig mod p_occ
 138        ; let lookup_sub occ | occ == p_occ = return p_name
 139                             | otherwise    = lookup_orig mod occ (Just p_name)
 140        ; mappM lookup_sub occs }
 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, via C( op ). If the class was exported too we'd
 144         -- have C( C, op )
 145
 146         -- The use of lookupOrigSub here (rather than lookupOrig)
 147         -- ensures that the subordinate names record their parent;
 148         -- and that in turn ensures that the GlobalRdrEnv
 149         -- has the correct parent for all the names in its range.
 150         -- For imported things, we may only suck in the interface later, if ever.
 151         -- Reason for all this:
 152         --   Suppose module M exports type A.T, and constructor A.MkT
 153         --   Then, we know that A.MkT is a subordinate name of A.T,
 154         --   even though we aren't at the binding site of A.T
 155         --   And it's important, because we may simply re-export A.T
 156         --   without ever sucking in the declaration itself.
 157
 158
 159 lookupOrig :: Module -> OccName -> TcRnIf a b Name
 160 -- Even if we get a miss in the original-name cache, we
 161 -- make a new External Name.
 162 -- We fake up
 163 --      SrcLoc to noSrcLoc
 164 --      Parent no Nothing
 165 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
 166 lookupOrig mod occ = lookup_orig mod occ Nothing
 167
 168 lookup_orig :: Module -> OccName ->  Maybe Name -> TcRnIf a b Name
 169 -- Used when we know the parent of the thing we are looking up
 170 lookup_orig mod occ mb_parent
 171   = do  {       -- First ensure that mod and occ are evaluated
 172                 -- If not, chaos can ensue:
 173                 --      we read the name-cache
 174                 --      then pull on mod (say)
 175                 --      which does some stuff that modifies the name cache
 176                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 177           mod `seq` occ `seq` return ()
 178
 179         ; name_supply <- getNameCache
 180         ; case lookupOrigNameCache (nsNames name_supply) mod occ of {
 181               Just name -> returnM name ;
 182               Nothing   -> do
 183
 184         { let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 185               ; uniq            = uniqFromSupply us1
 186               ; name            = mkExternalName uniq mod occ mb_parent noSrcLoc
 187               ; new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 188               ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 189           }
 190         ; setNameCache new_name_supply
 191         ; return name }
 192     }}
 193
 194 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 195 newIPName occ_name_ip
 196   = getNameCache                `thenM` \ name_supply ->
 197     let
 198         ipcache = nsIPs name_supply
 199     in
 200     case lookupFM ipcache key of
 201         Just name_ip -> returnM name_ip
 202         Nothing      -> setNameCache new_ns     `thenM_`
 203                         returnM name_ip
 204                   where
 205                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 206                      uniq        = uniqFromSupply us1
 207                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 208                      new_ipcache = addToFM ipcache key name_ip
 209                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 210     where
 211         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 212 \end{code}
 213
 214         Local helper functions (not exported)
 215
 216 \begin{code}
 217 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 218 lookupOrigNameCache nc mod occ
 219   | mod == pREL_TUP || mod == gHC_PRIM,         -- Boxed tuples from one,
 220     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 221   =     -- Special case for tuples; there are too many
 222         -- of them to pre-populate the original-name cache
 223     Just (mk_tup_name tup_info)
 224   where
 225     mk_tup_name (ns, boxity, arity)
 226         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 227         | ns == dataName = dataConName (tupleCon boxity arity)
 228         | otherwise      = varName (dataConWorkId (tupleCon boxity arity))
 229
 230 lookupOrigNameCache nc mod occ  -- The normal case
 231   = case lookupModuleEnv nc mod of
 232         Nothing      -> Nothing
 233         Just occ_env -> lookupOccEnv occ_env occ
 234
 235 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 236 extendOrigNameCache nc name
 237   = extend_name_cache nc (nameModule name) (nameOccName name) name
 238
 239 extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 240 extend_name_cache nc mod occ name
 241   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 242   where
 243     combine occ_env _ = extendOccEnv occ_env occ name
 244
 245 getNameCache :: TcRnIf a b NameCache
 246 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 247                     readMutVar nc_var }
 248
 249 setNameCache :: NameCache -> TcRnIf a b ()
 250 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 251                        writeMutVar nc_var nc }
 252 \end{code}
 253
 254
 255 \begin{code}
 256 initNameCache :: UniqSupply -> [Name] -> NameCache
 257 initNameCache us names
 258   = NameCache { nsUniqs = us,
 259                 nsNames = initOrigNames names,
 260                 nsIPs   = emptyFM }
 261
 262 initOrigNames :: [Name] -> OrigNameCache
 263 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 264 \end{code}
 265
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270                 Type variables and local Ids
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 tcIfaceLclId :: OccName -> IfL Id
 276 tcIfaceLclId occ
 277   = do  { lcl <- getLclEnv
 278         ; return (lookupOccEnv (if_id_env lcl) occ
 279                   `orElse`
 280                   pprPanic "tcIfaceLclId" (ppr occ)) }
 281
 282 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 283 extendIfaceIdEnv ids thing_inside
 284   = do  { env <- getLclEnv
 285         ; let { id_env' = extendOccEnvList (if_id_env env) pairs
 286               ; pairs   = [(getOccName id, id) | id <- ids] }
 287         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 288
 289
 290 tcIfaceTyVar :: OccName -> IfL TyVar
 291 tcIfaceTyVar occ
 292   = do  { lcl <- getLclEnv
 293         ; return (lookupOccEnv (if_tv_env lcl) occ
 294                   `orElse`
 295                   pprPanic "tcIfaceTyVar" (ppr occ)) }
 296
 297 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 298 extendIfaceTyVarEnv tyvars thing_inside
 299   = do  { env <- getLclEnv
 300         ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
 301               ; pairs   = [(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 lookupIfaceTc :: IfaceTyCon -> IfL Name
 314 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 315 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 316
 317 lookupIfaceExt :: IfaceExtName -> IfL Name
 318 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 319 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 320 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 321 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 322
 323 lookupIfaceTop :: OccName -> IfL Name
 324 -- Look up a top-level name from the current Iface module
 325 lookupIfaceTop occ
 326   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 327
 328 newIfaceName :: OccName -> IfL Name
 329 newIfaceName occ
 330   = do  { uniq <- newUnique
 331         ; return (mkInternalName uniq occ noSrcLoc) }
 332
 333 newIfaceNames :: [OccName] -> IfL [Name]
 334 newIfaceNames occs
 335   = do  { uniqs <- newUniqueSupply
 336         ; return [ mkInternalName uniq occ noSrcLoc
 337                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 338 \end{code}