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