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, lookupImplicitOrig, lookupIfaceTc,
   8         newIfaceName, newIfaceNames,
   9         extendIfaceIdEnv, extendIfaceTyVarEnv,
  10         tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
  11         tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId,
  12
  13         -- Name-cache stuff
  14         allocateGlobalBinder, extendOrigNameCache, initNameCache
  15    ) where
  16
  17 #include "HsVersions.h"
  18
  19 import {-# SOURCE #-}   TcIface( tcImportDecl )
  20
  21 import TcRnMonad
  22 import IfaceType        ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
  23 import HscTypes         ( NameCache(..), HscEnv(..),
  24                           TyThing, tyThingClass, tyThingTyCon,
  25                           ExternalPackageState(..), OrigNameCache, lookupType )
  26 import TyCon            ( TyCon, tyConName )
  27 import Class            ( Class )
  28 import DataCon          ( DataCon, dataConWorkId, dataConName )
  29 import Var              ( TyVar, Id, varName )
  30 import Name             ( Name, nameUnique, nameModule, nameModuleName,
  31                           nameOccName, nameSrcLoc,
  32                           getOccName, nameParent_maybe,
  33                           isWiredInName, nameIsLocalOrFrom, mkIPName,
  34                           mkExternalName, mkInternalName )
  35 import NameEnv
  36 import OccName          ( OccName, isTupleOcc_maybe, tcName, dataName,
  37                           lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
  38 import PrelNames        ( gHC_PRIM_Name, pREL_TUP_Name )
  39 import TysWiredIn       ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon,
  40                           tupleTyCon, tupleCon )
  41 import HscTypes         ( ExternalPackageState, NameCache, TyThing(..) )
  42 import Module           ( Module, ModuleName, moduleName, mkPackageModule,
  43                           emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
  44 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
  45 import FiniteMap        ( emptyFM, lookupFM, addToFM )
  46 import BasicTypes       ( IPName(..), mapIPName )
  47 import SrcLoc           ( SrcLoc, noSrcLoc )
  48 import Maybes           ( orElse )
  49
  50 import Outputable
  51 \end{code}
  52
  53
  54 %*********************************************************
  55 %*                                                      *
  56         Allocating new Names in the Name Cache
  57 %*                                                      *
  58 %*********************************************************
  59
  60 \begin{code}
  61 newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
  62 -- Used for source code and interface files, to make the
  63 -- Name for a thing, given its Module and OccName
  64 --
  65 -- The cache may already already have a binding for this thing,
  66 -- because we may have seen an occurrence before, but now is the
  67 -- moment when we know its Module and SrcLoc in their full glory
  68
  69 newGlobalBinder mod occ mb_parent loc
  70   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  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) (moduleName 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 Module and SrcLoc
  86         -- of the Name, so we set these fields in the Name we return.
  87         --
  88         -- This is essential, to get the right Module in a Name.
  89         -- Also: then (bogus) multiple bindings of the same Name
  90         --              get different SrcLocs can can be reported as such.
  91         --
  92         -- Possible other reason: it might be in the cache because we
  93         --      encountered an occurrence before the binding site for an
  94         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  95         --      better... but not really: it'll still just say 'imported'
  96         --
  97         -- IMPORTANT: Don't mess with wired-in names.
  98         --            Their wired-in-ness is in their NameSort
  99         --            and their Module is correct.
 100
 101         Just name | isWiredInName name -> (name_supply, name)
 102                   | otherwise -> (new_name_supply, name')
 103                   where
 104                     uniq      = nameUnique name
 105                     name'     = mkExternalName uniq mod occ mb_parent loc
 106                     new_cache = extend_name_cache (nsNames name_supply) mod occ name'
 107                     new_name_supply = name_supply {nsNames = new_cache}
 108
 109         -- Miss in the cache!
 110         -- Build a completely new Name, and put it in the cache
 111         Nothing -> (new_name_supply, name)
 112                 where
 113                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 114                   uniq            = uniqFromSupply us1
 115                   name            = mkExternalName uniq mod occ mb_parent loc
 116                   new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 117                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 118
 119
 120 newImplicitBinder :: Name                       -- Base name
 121                   -> (OccName -> OccName)       -- Occurrence name modifier
 122                   -> TcRnIf m n Name            -- Implicit name
 123 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 124 -- For source type/class decls, this is the first occurrence
 125 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 126 --
 127 -- An *implicit* name has the base-name as parent
 128 newImplicitBinder base_name mk_sys_occ
 129   = newGlobalBinder (nameModule base_name)
 130                     (mk_sys_occ (nameOccName base_name))
 131                     (Just parent_name)
 132                     (nameSrcLoc base_name)
 133   where
 134     parent_name = case nameParent_maybe base_name of
 135                     Just parent_name  -> parent_name
 136                     Nothing           -> base_name
 137
 138 lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name
 139 -- This one starts with a ModuleName, not a Module, because
 140 -- we may be simply looking at an occurrence M.x in an interface file.
 141 -- We may enounter this well before finding the binding site for M.x
 142 --
 143 -- So, even if we get a miss in the original-name cache, we
 144 -- make a new External Name.
 145 -- We fake up
 146 --      Module to AnotherPackage
 147 --      SrcLoc to noSrcLoc
 148 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
 149 lookupOrig mod_name occ = lookupOrig_help mod_name occ Nothing
 150
 151 lookupImplicitOrig :: Name -> OccName -> TcRnIf m n Name
 152 -- Same as lookupOrig, but install (Just parent) as the
 153 -- parent Name.   This is used when looking at the exports
 154 -- of an interface:
 155 --   Suppose module M exports type A.T, and constructor A.MkT
 156 --   Then, we know that A.MkT is an implicit name of A.T,
 157 --   even though we aren't at the binding site of A.T
 158 --   And it's important, because we may simply re-export A.T
 159 --   without ever sucking in the declaration itself.
 160 lookupImplicitOrig name occ
 161   = lookupOrig_help (nameModuleName name) occ (Just name)
 162
 163 lookupOrig_help :: ModuleName -> OccName -> Maybe Name -> TcRnIf a b Name
 164 -- Local helper, not exported
 165 lookupOrig_help mod_name occ mb_parent
 166   = do  {       -- First ensure that mod_name and occ are evaluated
 167                 -- If not, chaos can ensue:
 168                 --      we read the name-cache
 169                 --      then pull on mod (say)
 170                 --      which does some stuff that modifies the name cache
 171                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 172           mod `seq` occ `seq` return ()
 173
 174         ; name_supply <- getNameCache
 175         ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of {
 176               Just name -> returnM name ;
 177               Nothing   -> do
 178
 179         { let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 180               ; uniq            = uniqFromSupply us1
 181               ; name            = mkExternalName uniq tmp_mod occ mb_parent noSrcLoc
 182               ; new_cache       = extend_name_cache (nsNames name_supply) tmp_mod occ name
 183               ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 184               ; tmp_mod         = mkPackageModule mod_name
 185                         -- Guess at the package-ness for now, becuase we don't know whether
 186                         -- this imported module is from the home package or not.
 187                         -- If we ever need it, we'll open its interface, and update the cache
 188                         -- with a better name (newGlobalBinder)
 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 -> ModuleName -> OccName -> Maybe Name
 218 lookupOrigNameCache nc mod_name occ
 219   | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name,     -- 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_name occ     -- The normal case
 231   = case lookupModuleEnvByName nc mod_name 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                 Getting from Names to TyThings
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 tcIfaceGlobal :: Name -> IfM a TyThing
 275 tcIfaceGlobal name
 276   = do  { eps <- getEps
 277         ; hpt <- getHpt
 278         ; case lookupType hpt (eps_PTE eps) name of {
 279             Just thing -> return thing ;
 280             Nothing    ->
 281
 282         setLclEnv () $ do
 283         { env <- getGblEnv
 284         ; case if_rec_types env of
 285             Just (mod, get_type_env)
 286                 | nameIsLocalOrFrom mod name
 287                 -> do           -- It's defined in the module being compiled
 288                 { type_env <- get_type_env
 289                 ; case lookupNameEnv type_env name of
 290                         Just thing -> return thing
 291                         Nothing    -> pprPanic "tcIfaceGlobal (local): not found:"
 292                                                 (ppr name $$ ppr type_env) }
 293
 294             other -> tcImportDecl name  -- It's imported; go get it
 295     }}}
 296
 297 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
 298 tcIfaceTyCon IfaceIntTc = return intTyCon
 299 tcIfaceTyCon IfaceBoolTc = return boolTyCon
 300 tcIfaceTyCon IfaceCharTc = return charTyCon
 301 tcIfaceTyCon IfaceListTc = return listTyCon
 302 tcIfaceTyCon IfacePArrTc = return parrTyCon
 303 tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
 304 tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
 305                                    ; thing <- tcIfaceGlobal name
 306                                    ; return (tyThingTyCon thing) }
 307
 308 tcIfaceClass :: IfaceExtName -> IfL Class
 309 tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
 310                            ; thing <- tcIfaceGlobal name
 311                            ; return (tyThingClass thing) }
 312
 313 tcIfaceDataCon :: IfaceExtName -> IfL DataCon
 314 tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
 315                         ; thing <- tcIfaceGlobal name
 316                         ; case thing of
 317                                 ADataCon dc -> return dc
 318                                 other   -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
 319
 320 tcIfaceExtId :: IfaceExtName -> IfL Id
 321 tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
 322                       ; thing <- tcIfaceGlobal name
 323                       ; case thing of
 324                           AnId id -> return id
 325                           other   -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
 326
 327 ------------------------------------------
 328 tcIfaceLclId :: OccName -> IfL Id
 329 tcIfaceLclId occ
 330   = do  { lcl <- getLclEnv
 331         ; return (lookupOccEnv (if_id_env lcl) occ
 332                   `orElse`
 333                   pprPanic "tcIfaceLclId" (ppr occ)) }
 334
 335 tcIfaceTyVar :: OccName -> IfL TyVar
 336 tcIfaceTyVar occ
 337   = do  { lcl <- getLclEnv
 338         ; return (lookupOccEnv (if_tv_env lcl) occ
 339                   `orElse`
 340                   pprPanic "tcIfaceTyVar" (ppr occ)) }
 341
 342 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 343 extendIfaceIdEnv ids thing_inside
 344   = do  { env <- getLclEnv
 345         ; let { id_env' = extendOccEnvList (if_id_env env) pairs
 346               ; pairs   = [(getOccName id, id) | id <- ids] }
 347         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 348
 349 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 350 extendIfaceTyVarEnv tyvars thing_inside
 351   = do  { env <- getLclEnv
 352         ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
 353               ; pairs   = [(getOccName tv, tv) | tv <- tyvars] }
 354         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 355 \end{code}
 356
 357
 358 %************************************************************************
 359 %*                                                                      *
 360                 Getting from RdrNames to Names
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 IfaceDecls etc are populated with RdrNames.  The RdrNames may either be
 365
 366   Orig or Unqual        when the interface is read from a file
 367
 368   Exact                 when the interface is kept by GHCi, and is now
 369                         being re-linked with the type environment
 370
 371 At an occurrence site, to convert the RdrName to Name:
 372   Unqual        look up in LocalRdrEnv
 373   Orig          look up in OrigNameCache
 374   Exact         return the Name
 375
 376 At a binding site, to bind the RdrName
 377   Unqual                we extend the LocalRdrEnv
 378   Orig or Unqual        we don't extend the LocalRdrEnv (no need)
 379
 380 First, we deal with the RdrName -> Name mapping
 381
 382 \begin{code}
 383 lookupIfaceTc :: IfaceTyCon -> IfL Name
 384 lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
 385 lookupIfaceTc other_tc      = return (ifaceTyConName other_tc)
 386
 387 lookupIfaceExt :: IfaceExtName -> IfL Name
 388 lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
 389 lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
 390 lookupIfaceExt (LocalTop occ)      = lookupIfaceTop occ
 391 lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
 392
 393 lookupIfaceTop :: OccName -> IfL Name
 394 -- Look up a top-level name from the current Iface module
 395 lookupIfaceTop occ
 396   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 397
 398 newIfaceName :: OccName -> IfL Name
 399 newIfaceName occ
 400   = do  { uniq <- newUnique
 401         ; return (mkInternalName uniq occ noSrcLoc) }
 402
 403 newIfaceNames :: [OccName] -> IfL [Name]
 404 newIfaceNames occs
 405   = do  { uniqs <- newUniqueSupply
 406         ; return [ mkInternalName uniq occ noSrcLoc
 407                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 408 \end{code}