compiler/iface/IfaceEnv.lhs

   1 (c) The University of Glasgow 2002-2006
   2
   3 \begin{code}
   4 {-# OPTIONS_GHC -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/WorkingConventions#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 <- mappM 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 -> returnM 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
 177   = getNameCache                `thenM` \ name_supply ->
 178     let
 179         ipcache = nsIPs name_supply
 180     in
 181     case lookupFM ipcache key of
 182         Just name_ip -> returnM name_ip
 183         Nothing      -> setNameCache new_ns     `thenM_`
 184                         returnM name_ip
 185                   where
 186                      (us', us1)  = splitUniqSupply (nsUniqs name_supply)
 187                      uniq        = uniqFromSupply us1
 188                      name_ip     = mapIPName (mkIPName uniq) occ_name_ip
 189                      new_ipcache = addToFM ipcache key name_ip
 190                      new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
 191     where
 192         key = occ_name_ip       -- Ensures that ?x and %x get distinct Names
 193 \end{code}
 194
 195         Local helper functions (not exported)
 196
 197 \begin{code}
 198 lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
 199 lookupOrigNameCache nc mod occ
 200   | mod == dATA_TUP || mod == gHC_PRIM,         -- Boxed tuples from one,
 201     Just tup_info <- isTupleOcc_maybe occ       -- unboxed from the other
 202   =     -- Special case for tuples; there are too many
 203         -- of them to pre-populate the original-name cache
 204     Just (mk_tup_name tup_info)
 205   where
 206     mk_tup_name (ns, boxity, arity)
 207         | ns == tcName   = tyConName (tupleTyCon boxity arity)
 208         | ns == dataName = dataConName (tupleCon boxity arity)
 209         | otherwise      = Var.varName (dataConWorkId (tupleCon boxity arity))
 210
 211 lookupOrigNameCache nc mod occ  -- The normal case
 212   = case lookupModuleEnv nc mod of
 213         Nothing      -> Nothing
 214         Just occ_env -> lookupOccEnv occ_env occ
 215
 216 extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
 217 extendOrigNameCache nc name
 218   = extendNameCache nc (nameModule name) (nameOccName name) name
 219
 220 extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
 221 extendNameCache nc mod occ name
 222   = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
 223   where
 224     combine occ_env _ = extendOccEnv occ_env occ name
 225
 226 getNameCache :: TcRnIf a b NameCache
 227 getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 228                     readMutVar nc_var }
 229
 230 setNameCache :: NameCache -> TcRnIf a b ()
 231 setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
 232                        writeMutVar nc_var nc }
 233 \end{code}
 234
 235
 236 \begin{code}
 237 initNameCache :: UniqSupply -> [Name] -> NameCache
 238 initNameCache us names
 239   = NameCache { nsUniqs = us,
 240                 nsNames = initOrigNames names,
 241                 nsIPs   = emptyFM }
 242
 243 initOrigNames :: [Name] -> OrigNameCache
 244 initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
 245 \end{code}
 246
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251                 Type variables and local Ids
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 tcIfaceLclId :: FastString -> IfL Id
 257 tcIfaceLclId occ
 258   = do  { lcl <- getLclEnv
 259         ; case (lookupUFM (if_id_env lcl) occ) of
 260             Just ty_var -> return ty_var
 261             Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
 262         }
 263
 264 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 265 extendIfaceIdEnv ids thing_inside
 266   = do  { env <- getLclEnv
 267         ; let { id_env' = addListToUFM (if_id_env env) pairs
 268               ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
 269         ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
 270
 271
 272 tcIfaceTyVar :: FastString -> IfL TyVar
 273 tcIfaceTyVar occ
 274   = do  { lcl <- getLclEnv
 275         ; case (lookupUFM (if_tv_env lcl) occ) of
 276             Just ty_var -> return ty_var
 277             Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
 278         }
 279
 280 extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
 281 extendIfaceTyVarEnv tyvars thing_inside
 282   = do  { env <- getLclEnv
 283         ; let { tv_env' = addListToUFM (if_tv_env env) pairs
 284               ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
 285         ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
 286 \end{code}
 287
 288
 289 %************************************************************************
 290 %*                                                                      *
 291                 Getting from RdrNames to Names
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 \begin{code}
 296 lookupIfaceTop :: OccName -> IfL Name
 297 -- Look up a top-level name from the current Iface module
 298 lookupIfaceTop occ
 299   = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
 300
 301 newIfaceName :: OccName -> IfL Name
 302 newIfaceName occ
 303   = do  { uniq <- newUnique
 304         ; return $! mkInternalName uniq occ noSrcSpan }
 305
 306 newIfaceNames :: [OccName] -> IfL [Name]
 307 newIfaceNames occs
 308   = do  { uniqs <- newUniqueSupply
 309         ; return [ mkInternalName uniq occ noSrcSpan
 310                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315                 (Re)creating tick boxes
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 \begin{code}
 320 tcIfaceTick :: Module -> Int -> IfL Id
 321 tcIfaceTick modName tickNo
 322   = do { uniq <- newUnique
 323        ; return $ mkTickBoxOpId uniq modName tickNo
 324        }
 325 \end{code}
 326
 327