1 files changed, 359 insertions, 0 deletions
diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
new file mode 100644
index 0000000000..40b7d31f13
--- /dev/null
+++ b/compiler/iface/IfaceEnv.lhs
@@ -0,0 +1,359 @@
+(c) The University of Glasgow 2002
+
+\begin{code}
+module IfaceEnv (
+	newGlobalBinder, newIPName, newImplicitBinder, 
+	lookupIfaceTop, lookupIfaceExt,
+	lookupOrig, lookupIfaceTc,
+	newIfaceName, newIfaceNames,
+	extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
+	tcIfaceLclId,     tcIfaceTyVar, 
+
+	lookupAvail, ifaceExportNames,
+
+	-- Name-cache stuff
+	allocateGlobalBinder, initNameCache, 
+   ) where
+
+#include "HsVersions.h"
+
+import TcRnMonad
+import IfaceType	( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
+import TysWiredIn	( tupleTyCon, tupleCon )
+import HscTypes		( NameCache(..), HscEnv(..), GenAvailInfo(..), 
+			  IfaceExport, OrigNameCache )
+import Type		( mkOpenTvSubst, substTy )
+import TyCon		( TyCon, tyConName )
+import Unify		( TypeRefinement )
+import DataCon		( dataConWorkId, dataConName )
+import Var		( TyVar, Id, varName, setIdType, idType )
+import Name		( Name, nameUnique, nameModule, 
+			  nameOccName, nameSrcLoc, 
+			  getOccName, nameParent_maybe,
+		  	  isWiredInName, mkIPName,
+			  mkExternalName, mkInternalName )
+import NameSet		( NameSet, emptyNameSet, addListToNameSet )
+import OccName		( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv,
+			  lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
+import PrelNames	( gHC_PRIM, pREL_TUP )
+import Module		( Module, emptyModuleEnv, 
+			  lookupModuleEnv, extendModuleEnv_C )
+import UniqSupply	( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
+import FiniteMap	( emptyFM, lookupFM, addToFM )
+import BasicTypes	( IPName(..), mapIPName )
+import SrcLoc		( SrcLoc, noSrcLoc )
+import Maybes		( orElse )
+
+import Outputable
+\end{code}
+
+
+%*********************************************************
+%*							*
+	Allocating new Names in the Name Cache
+%*							*
+%*********************************************************
+
+\begin{code}
+newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
+-- Used for source code and interface files, to make the
+-- Name for a thing, given its Module and OccName
+--
+-- The cache may already already have a binding for this thing,
+-- because we may have seen an occurrence before, but now is the
+-- moment when we know its Module and SrcLoc in their full glory
+
+newGlobalBinder mod occ mb_parent loc
+  = do	{ mod `seq` occ `seq` return ()	-- See notes with lookupOrig_help
+	-- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
+    	; name_supply <- getNameCache
+	; let (name_supply', name) = allocateGlobalBinder 
+					name_supply mod occ
+					mb_parent loc
+	; setNameCache name_supply'
+	; return name }
+
+allocateGlobalBinder
+  :: NameCache 
+  -> Module -> OccName -> Maybe Name -> SrcLoc 
+  -> (NameCache, Name)
+allocateGlobalBinder name_supply mod occ mb_parent loc
+  = case lookupOrigNameCache (nsNames name_supply) mod occ of
+	-- A hit in the cache!  We are at the binding site of the name.
+	-- This is the moment when we know the defining parent and SrcLoc
+	-- of the Name, so we set these fields in the Name we return.
+	--
+	-- Then (bogus) multiple bindings of the same Name
+	-- get different SrcLocs can can be reported as such.
+	--
+	-- Possible other reason: it might be in the cache because we
+	-- 	encountered an occurrence before the binding site for an
+	--	implicitly-imported Name.  Perhaps the current SrcLoc is
+	--	better... but not really: it'll still just say 'imported'
+	--
+	-- IMPORTANT: Don't mess with wired-in names.  
+	-- 	      Their wired-in-ness is in their NameSort
+	--	      and their Module is correct.
+
+	Just name | isWiredInName name -> (name_supply, name)
+		  | otherwise -> (new_name_supply, name')
+		  where
+		    uniq      = nameUnique name
+		    name'     = mkExternalName uniq mod occ mb_parent loc
+		    new_cache = extend_name_cache (nsNames name_supply) mod occ name'
+		    new_name_supply = name_supply {nsNames = new_cache}		     
+
+	-- Miss in the cache!
+	-- Build a completely new Name, and put it in the cache
+	Nothing -> (new_name_supply, name)
+		where
+		  (us', us1)      = splitUniqSupply (nsUniqs name_supply)
+		  uniq   	  = uniqFromSupply us1
+		  name            = mkExternalName uniq mod occ mb_parent loc
+		  new_cache       = extend_name_cache (nsNames name_supply) mod occ name
+		  new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+
+newImplicitBinder :: Name			-- Base name
+	          -> (OccName -> OccName) 	-- Occurrence name modifier
+	          -> TcRnIf m n Name		-- Implicit name
+-- Called in BuildTyCl to allocate the implicit binders of type/class decls
+-- For source type/class decls, this is the first occurrence
+-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache
+--
+-- An *implicit* name has the base-name as parent
+newImplicitBinder base_name mk_sys_occ
+  = newGlobalBinder (nameModule base_name)
+		    (mk_sys_occ (nameOccName base_name))
+		    (Just parent_name)
+		    (nameSrcLoc base_name)    
+  where
+    parent_name = case nameParent_maybe base_name of
+		    Just parent_name  -> parent_name
+		    Nothing 	      -> base_name
+
+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
+ifaceExportNames exports 
+  = foldlM do_one emptyNameSet exports
+  where
+    do_one acc (mod, exports)  = foldlM (do_avail mod) acc exports
+    do_avail mod acc avail = do { ns <- lookupAvail mod avail
+				; return (addListToNameSet acc ns) }
+
+lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
+-- Find all the names arising from an import
+-- Make sure the parent info is correct, even though we may not
+-- yet have read the interface for this module
+lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n; 
+			       ; return [n'] }
+lookupAvail mod (AvailTC p_occ occs) 
+  = do { p_name <- lookupOrig mod p_occ
+       ; let lookup_sub occ | occ == p_occ = return p_name
+			    | otherwise	   = lookup_orig mod occ (Just p_name)
+       ; mappM lookup_sub occs }
+	-- Remember that 'occs' is all the exported things, including
+	-- the parent.  It's possible to export just class ops without
+	-- the class, via C( op ). If the class was exported too we'd
+	-- have C( C, op )
+
+	-- The use of lookupOrigSub here (rather than lookupOrig) 
+	-- ensures that the subordinate names record their parent; 
+	-- and that in turn ensures that the GlobalRdrEnv
+	-- has the correct parent for all the names in its range.
+	-- For imported things, we may only suck in the interface later, if ever.
+	-- Reason for all this:
+	--   Suppose module M exports type A.T, and constructor A.MkT
+	--   Then, we know that A.MkT is a subordinate name of A.T,
+	--   even though we aren't at the binding site of A.T
+	--   And it's important, because we may simply re-export A.T
+	--   without ever sucking in the declaration itself.
+
+
+lookupOrig :: Module -> OccName -> TcRnIf a b Name
+-- Even if we get a miss in the original-name cache, we 
+-- make a new External Name. 
+-- We fake up 
+-- 	SrcLoc to noSrcLoc
+--	Parent no Nothing
+-- They'll be overwritten, in due course, by LoadIface.loadDecl.
+lookupOrig mod occ = lookup_orig mod occ Nothing
+
+lookup_orig :: Module -> OccName ->  Maybe Name -> TcRnIf a b Name
+-- Used when we know the parent of the thing we are looking up
+lookup_orig mod occ mb_parent
+  = do 	{ 	-- First ensure that mod and occ are evaluated
+		-- If not, chaos can ensue:
+		-- 	we read the name-cache
+		-- 	then pull on mod (say)
+		--	which does some stuff that modifies the name cache
+		-- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+	  mod `seq` occ `seq` return ()	
+    
+	; name_supply <- getNameCache
+    	; case lookupOrigNameCache (nsNames name_supply) mod occ of {
+	      Just name -> returnM name ;
+	      Nothing   -> do 
+
+	{ let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
+	      ;	uniq   	  	= uniqFromSupply us1
+	      ;	name            = mkExternalName uniq mod occ mb_parent noSrcLoc
+	      ;	new_cache       = extend_name_cache (nsNames name_supply) mod occ name
+	      ;	new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+	  }
+	; setNameCache new_name_supply
+	; return name }
+    }}
+
+newIPName :: IPName OccName -> TcRnIf m n (IPName Name)
+newIPName occ_name_ip
+  = getNameCache		`thenM` \ name_supply ->
+    let
+	ipcache = nsIPs name_supply
+    in
+    case lookupFM ipcache key of
+	Just name_ip -> returnM name_ip
+	Nothing      -> setNameCache new_ns 	`thenM_`
+		        returnM name_ip
+		  where
+		     (us', us1)  = splitUniqSupply (nsUniqs name_supply)
+		     uniq   	 = uniqFromSupply us1
+		     name_ip	 = mapIPName (mkIPName uniq) occ_name_ip
+		     new_ipcache = addToFM ipcache key name_ip
+		     new_ns	 = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+    where 
+	key = occ_name_ip	-- Ensures that ?x and %x get distinct Names
+\end{code}
+
+	Local helper functions (not exported)
+
+\begin{code}
+lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
+lookupOrigNameCache nc mod occ
+  | mod == pREL_TUP || mod == gHC_PRIM,		-- Boxed tuples from one, 
+    Just tup_info <- isTupleOcc_maybe occ	-- unboxed from the other
+  = 	-- Special case for tuples; there are too many
+	-- of them to pre-populate the original-name cache
+    Just (mk_tup_name tup_info)
+  where
+    mk_tup_name (ns, boxity, arity)
+	| ns == tcName   = tyConName (tupleTyCon boxity arity)
+	| ns == dataName = dataConName (tupleCon boxity arity)
+	| otherwise      = varName (dataConWorkId (tupleCon boxity arity))
+
+lookupOrigNameCache nc mod occ	-- The normal case
+  = case lookupModuleEnv nc mod of
+	Nothing      -> Nothing
+	Just occ_env -> lookupOccEnv occ_env occ
+
+extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
+extendOrigNameCache nc name 
+  = extend_name_cache nc (nameModule name) (nameOccName name) name
+
+extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
+extend_name_cache nc mod occ name
+  = extendModuleEnv_C combine nc mod (unitOccEnv occ name)
+  where
+    combine occ_env _ = extendOccEnv occ_env occ name
+
+getNameCache :: TcRnIf a b NameCache
+getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
+		    readMutVar nc_var }
+
+setNameCache :: NameCache -> TcRnIf a b ()
+setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; 
+		       writeMutVar nc_var nc }
+\end{code}
+
+
+\begin{code}
+initNameCache :: UniqSupply -> [Name] -> NameCache
+initNameCache us names
+  = NameCache { nsUniqs = us,
+		nsNames = initOrigNames names,
+		nsIPs   = emptyFM }
+
+initOrigNames :: [Name] -> OrigNameCache
+initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+		Type variables and local Ids
+%*									*
+%************************************************************************
+
+\begin{code}
+tcIfaceLclId :: OccName -> IfL Id
+tcIfaceLclId occ
+  = do	{ lcl <- getLclEnv
+	; return (lookupOccEnv (if_id_env lcl) occ
+		  `orElse` 
+		  pprPanic "tcIfaceLclId" (ppr occ)) }
+
+refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
+refineIfaceIdEnv (tv_subst, _) thing_inside
+  = do	{ env <- getLclEnv
+	; let { id_env' = mapOccEnv refine_id (if_id_env env)
+	      ;	refine_id id = setIdType id (substTy subst (idType id))
+	      ;	subst = mkOpenTvSubst tv_subst }
+	; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+	
+extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
+extendIfaceIdEnv ids thing_inside
+  = do	{ env <- getLclEnv
+	; let { id_env' = extendOccEnvList (if_id_env env) pairs
+	      ;	pairs   = [(getOccName id, id) | id <- ids] }
+	; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+
+
+tcIfaceTyVar :: OccName -> IfL TyVar
+tcIfaceTyVar occ
+  = do	{ lcl <- getLclEnv
+	; return (lookupOccEnv (if_tv_env lcl) occ
+		  `orElse`
+		  pprPanic "tcIfaceTyVar" (ppr occ)) }
+
+extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
+extendIfaceTyVarEnv tyvars thing_inside
+  = do	{ env <- getLclEnv
+	; let { tv_env' = extendOccEnvList (if_tv_env env) pairs
+	      ;	pairs   = [(getOccName tv, tv) | tv <- tyvars] }
+	; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+\end{code}
+
+
+%************************************************************************
+%*									*
+		Getting from RdrNames to Names
+%*									*
+%************************************************************************
+
+\begin{code}
+lookupIfaceTc :: IfaceTyCon -> IfL Name
+lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
+lookupIfaceTc other_tc	    = return (ifaceTyConName other_tc)
+
+lookupIfaceExt :: IfaceExtName -> IfL Name
+lookupIfaceExt (ExtPkg  mod occ)   = lookupOrig mod occ
+lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ
+lookupIfaceExt (LocalTop occ)	   = lookupIfaceTop occ
+lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ
+
+lookupIfaceTop :: OccName -> IfL Name
+-- Look up a top-level name from the current Iface module
+lookupIfaceTop occ
+  = do	{ env <- getLclEnv; lookupOrig (if_mod env) occ }
+
+newIfaceName :: OccName -> IfL Name
+newIfaceName occ
+  = do	{ uniq <- newUnique
+	; return (mkInternalName uniq occ noSrcLoc) }
+
+newIfaceNames :: [OccName] -> IfL [Name]
+newIfaceNames occs
+  = do	{ uniqs <- newUniqueSupply
+	; return [ mkInternalName uniq occ noSrcLoc
+		 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+\end{code}