compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002-2006
   2
   3 \begin{code}
   4 {-# OPTIONS -w #-}
   5 -- The above warning supression flag is a temporary kludge.
   6 -- While working on this module you are encouraged to remove it and fix
   7 -- any warnings in the module. See
   8 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   9 -- for details
  10
  11 module IfaceEnv (
  12         newGlobalBinder, newIPName, newImplicitBinder,
  13         lookupIfaceTop,
  14         lookupOrig, lookupOrigNameCache, extendNameCache,
  15         newIfaceName, newIfaceNames,
  16         extendIfaceIdEnv, extendIfaceTyVarEnv,
  17         tcIfaceLclId,     tcIfaceTyVar,
  18         tcIfaceTick,
  19
  20         ifaceExportNames,
  21
  22         -- Name-cache stuff
  23         allocateGlobalBinder, initNameCache,
  24         getNameCache, setNameCache
  25    ) where
  26
  27 #include "HsVersions.h"
  28
  29 import TcRnMonad
  30 import TysWiredIn
  31 import HscTypes
  32 import TyCon
  33 import DataCon
  34 import Var
  35 import Name
  36 import OccName
  37 import PrelNames
  38 import Module
  39 import UniqFM
  40 import FastString
  41 import UniqSupply
  42 import FiniteMap
  43 import BasicTypes
  44 import SrcLoc
  45 import MkId
  46
  47 import Outputable
  48 \end{code}
  49
  50
  51 %*********************************************************
  52 %*                                                      *
  53         Allocating new Names in the Name Cache
  54 %*                                                      *
  55 %*********************************************************
  56
  57 \begin{code}
  58 newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
  59 -- Used for source code and interface files, to make the
  60 -- Name for a thing, given its Module and OccName
  61 --
  62 -- The cache may already already have a binding for this thing,
  63 -- because we may have seen an occurrence before, but now is the
  64 -- moment when we know its Module and SrcLoc in their full glory
  65
  66 newGlobalBinder mod occ loc
  67   = do  { mod `seq` occ `seq` return () -- See notes with lookupOrig_help
  68 --      ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
  69         ; name_supply <- getNameCache
  70         ; let (name_supply', name) = allocateGlobalBinder
  71                                         name_supply mod occ
  72                                         loc
  73         ; setNameCache name_supply'
  74         ; return name }
  75
  76 allocateGlobalBinder
  77   :: NameCache
  78   -> Module -> OccName -> SrcSpan
  79   -> (NameCache, Name)
  80 allocateGlobalBinder name_supply mod occ loc
  81   = case lookupOrigNameCache (nsNames name_supply) mod occ of
  82         -- A hit in the cache!  We are at the binding site of the name.
  83         -- This is the moment when we know the SrcLoc
  84         -- of the Name, so we set this field in the Name we return.
  85         --
  86         -- Then (bogus) multiple bindings of the same Name
  87         -- get different SrcLocs can can be reported as such.
  88         --
  89         -- Possible other reason: it might be in the cache because we
  90         --      encountered an occurrence before the binding site for an
  91         --      implicitly-imported Name.  Perhaps the current SrcLoc is
  92         --      better... but not really: it'll still just say 'imported'
  93         --
  94         -- IMPORTANT: Don't mess with wired-in names.
  95         --            Their wired-in-ness is in their NameSort
  96         --            and their Module is correct.
  97
  98         Just name | isWiredInName name -> (name_supply, name)
  99                   | otherwise -> (new_name_supply, name')
 100                   where
 101                     uniq      = nameUnique name
 102                     name'     = mkExternalName uniq mod occ loc
 103                     new_cache = extendNameCache (nsNames name_supply) mod occ name'
 104                     new_name_supply = name_supply {nsNames = new_cache}
 105
 106         -- Miss in the cache!
 107         -- Build a completely new Name, and put it in the cache
 108         Nothing -> (new_name_supply, name)
 109                 where
 110                   (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 111                   uniq            = uniqFromSupply us1
 112                   name            = mkExternalName uniq mod occ loc
 113                   new_cache       = extendNameCache (nsNames name_supply) mod occ name
 114                   new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 115
 116
 117 newImplicitBinder :: Name                       -- Base name
 118                   -> (OccName -> OccName)       -- Occurrence name modifier
 119                   -> TcRnIf m n Name            -- Implicit name
 120 -- Called in BuildTyCl to allocate the implicit binders of type/class decls
 121 -- For source type/class decls, this is the first occurrence
 122 -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
 123 newImplicitBinder base_name mk_sys_occ
 124   = newGlobalBinder (nameModule base_name)
 125                     (mk_sys_occ (nameOccName base_name))
 126                     (nameSrcSpan base_name)
 127
 128 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 129 ifaceExportNames exports = do
 130   mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports
 131   return (concat mod_avails)
 132
 133 -- Convert OccNames in GenAvailInfo to Names.
 134 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo
 135 lookupAvail mod (Avail n) = do
 136   n' <- lookupOrig mod n
 137   return (Avail n')
 138 lookupAvail mod (AvailTC p_occ occs) = do
 139   p_name <- lookupOrig mod p_occ
 140   let lookup_sub occ | occ == p_occ = return p_name
 141                      | otherwise    = lookupOrig mod occ
 142   subs <- mapM lookup_sub occs
 143   return (AvailTC p_name subs)
 144         -- Remember that 'occs' is all the exported things, including
 145         -- the parent.  It's possible to export just class ops without
 146         -- the class, which shows up as C( op ) here. If the class was
 147         -- exported too we'd have C( C, op )
 148
 149 lookupOrig :: Module -> OccName ->  TcRnIf a b Name
 150 lookupOrig mod occ
 151   = do  {       -- First ensure that mod and occ are evaluated
 152                 -- If not, chaos can ensue:
 153                 --      we read the name-cache
 154                 --      then pull on mod (say)
 155                 --      which does some stuff that modifies the name cache
 156                 -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
 157           mod `seq` occ `seq` return ()
 158 --      ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
 159
 160         ; name_cache <- getNameCache
 161         ; case lookupOrigNameCache (nsNames name_cache) mod occ of {
 162               Just name -> return name;
 163               Nothing   ->
 164               let
 165                 us        = nsUniqs name_cache
 166                 uniq      = uniqFromSupply us
 167                 name      = mkExternalName uniq mod occ noSrcSpan
 168                 new_cache = extendNameCache (nsNames name_cache) mod occ name
 169               in
 170               case splitUniqSupply us of { (us',_) -> do
 171                 setNameCache name_cache{ nsUniqs = us', nsNames = new_cache }
 172                 return name
 173     }}}
 174
 175 newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
 176 newIPName occ_name_ip = do
 177     name_supply <- getNameCache
 178     let
 179         ipcache = nsIPs name_supply
 180     case lookupFM ipcache key of
 181         Just name_ip -> return name_ip
 182         Nothing      -> do setNameCache new_ns
 183                            return name_ip
 184                   where
 185                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 186                      uniq        = uniqFromSupply us1
 187                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 188                      new_ipcache = addToFM ipcache key name_ip
 189                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 190     where
 191         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 192 \end{code}
 193
 194         Local helper functions (not exported)
 195
 196 \begin{code}
 197 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 198 lookupOrigNameCache nc mod occ
 199   | mod == dATA_TUP || mod == gHC_PRIM,         -- Boxed tuples from one,
 200     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 201   =     -- Special case for tuples; there are too many
 202         -- of them to pre-populate the original-name cache
 203     Just (mk_tup_name tup_info)
 204   where
 205     mk_tup_name (ns, boxity, arity)
 206         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 207         | ns == dataName = dataConName (tupleCon boxity arity)
 208         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 209
 210 lookupOrigNameCache nc mod occ  -- The normal case
 211   = case lookupModuleEnv nc mod of
 212         Nothing      -> Nothing
 213         Just occ_env -> lookupOccEnv occ_env occ
 214
 215 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 216 extendOrigNameCache nc name
 217   = extendNameCache nc (nameModule name) (nameOccName name) name
 218
 219 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 220 extendNameCache nc mod occ name
 221   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 222   where
 223     combine occ_env _ = extendOccEnv occ_env occ name
 224
 225 getNameCache :: TcRnIf a b NameCache
 226 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 227                     readMutVar nc_var }
 228
 229 setNameCache :: NameCache -> TcRnIf a b ()
 230 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 231                        writeMutVar nc_var nc }
 232 \end{code}
 233
 234
 235 \begin{code}
 236 initNameCache :: UniqSupply -> [Name] -> NameCache
 237 initNameCache us names
 238   = NameCache { nsUniqs = us,
 239                 nsNames = initOrigNames names,
 240                 nsIPs   = emptyFM }
 241
 242 initOrigNames :: [Name] -> OrigNameCache
 243 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 244 \end{code}
 245
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250                 Type variables and local Ids
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 tcIfaceLclId :: FastString -> IfL Id
 256 tcIfaceLclId occ
 257   = do  { lcl <- getLclEnv
 258         ; case (lookupUFM (if_id_env lcl) occ) of
 259             Just ty_var -> return ty_var
 260             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 261         }
 262
 263 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 264 extendIfaceIdEnv ids thing_inside
 265   = do  { env <- getLclEnv
 266         ; let { id_env' = addListToUFM (if_id_env env) pairs
 267               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 268         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 269
 270
 271 tcIfaceTyVar :: FastString -> IfL TyVar
 272 tcIfaceTyVar occ
 273   = do  { lcl <- getLclEnv
 274         ; case (lookupUFM (if_tv_env lcl) occ) of
 275             Just ty_var -> return ty_var
 276             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 277         }
 278
 279 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 280 extendIfaceTyVarEnv tyvars thing_inside
 281   = do  { env <- getLclEnv
 282         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 283               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 284         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 285 \end{code}
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290                 Getting from RdrNames to Names
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 lookupIfaceTop :: OccName -> IfL Name
 296 -- Look up a top-level name from the current Iface module
 297 lookupIfaceTop occ
 298   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 299
 300 newIfaceName :: OccName -> IfL Name
 301 newIfaceName occ
 302   = do  { uniq <- newUnique
 303         ; return $! mkInternalName uniq occ noSrcSpan }
 304
 305 newIfaceNames :: [OccName] -> IfL [Name]
 306 newIfaceNames occs
 307   = do  { uniqs <- newUniqueSupply
 308         ; return [ mkInternalName uniq occ noSrcSpan
 309                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314                 (Re)creating tick boxes
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 tcIfaceTick :: Module -> Int -> IfL Id
 320 tcIfaceTick modName tickNo
 321   = do { uniq <- newUnique
 322        ; return $ mkTickBoxOpId uniq modName tickNo
 323        }
 324 \end{code}
 325
 326