X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceEnv.lhs;h=20d7327cfeb515a43d6b8436486860b6419e7e05;hp=fe0b0cdb22d6495dbba0025bd17963ff14387180;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index fe0b0cd..20d7327 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -1,4 +1,4 @@ -(c) The University of Glasgow 2002 +(c) The University of Glasgow 2002-2006 \begin{code} module IfaceEnv ( @@ -8,6 +8,7 @@ module IfaceEnv ( newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, + tcIfaceTick, ifaceExportNames, @@ -19,29 +20,22 @@ module IfaceEnv ( #include "HsVersions.h" import TcRnMonad -import TysWiredIn ( tupleTyCon, tupleCon ) -import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), - IfaceExport, OrigNameCache, AvailInfo ) -import Type ( mkOpenTvSubst, substTy ) -import TyCon ( TyCon, tyConName ) -import DataCon ( dataConWorkId, dataConName ) -import Var ( TyVar, Id, varName ) -import Name ( Name, nameUnique, nameModule, - nameOccName, nameSrcLoc, getOccName, - isWiredInName, mkIPName, - mkExternalName, mkInternalName ) -import NameSet ( NameSet, emptyNameSet, addListToNameSet ) -import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, occNameFS, - lookupOccEnv, unitOccEnv, extendOccEnv ) -import PrelNames ( gHC_PRIM, dATA_TUP ) -import Module ( Module, emptyModuleEnv, ModuleName, modulePackageId, - lookupModuleEnv, extendModuleEnv_C, mkModule ) -import UniqFM ( lookupUFM, addListToUFM ) -import FastString ( FastString ) -import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) -import FiniteMap ( emptyFM, lookupFM, addToFM ) -import BasicTypes ( IPName(..), mapIPName ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import TysWiredIn +import HscTypes +import TyCon +import DataCon +import Var +import Name +import OccName +import PrelNames +import Module +import LazyUniqFM +import FastString +import UniqSupply +import FiniteMap +import BasicTypes +import SrcLoc +import MkId import Outputable \end{code} @@ -54,7 +48,7 @@ import Outputable %********************************************************* \begin{code} -newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName -- @@ -64,7 +58,7 @@ newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name newGlobalBinder mod occ loc = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help - ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) +-- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) ; name_supply <- getNameCache ; let (name_supply', name) = allocateGlobalBinder name_supply mod occ @@ -74,7 +68,7 @@ newGlobalBinder mod occ loc allocateGlobalBinder :: NameCache - -> Module -> OccName -> SrcLoc + -> Module -> OccName -> SrcSpan -> (NameCache, Name) allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of @@ -122,7 +116,7 @@ newImplicitBinder :: Name -- Base name newImplicitBinder base_name mk_sys_occ = newGlobalBinder (nameModule base_name) (mk_sys_occ (nameOccName base_name)) - (nameSrcLoc base_name) + (nameSrcSpan base_name) ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = do @@ -138,7 +132,7 @@ lookupAvail mod (AvailTC p_occ occs) = do p_name <- lookupOrig mod p_occ let lookup_sub occ | occ == p_occ = return p_name | otherwise = lookupOrig mod occ - subs <- mappM lookup_sub occs + subs <- mapM lookup_sub occs return (AvailTC p_name subs) -- Remember that 'occs' is all the exported things, including -- the parent. It's possible to export just class ops without @@ -154,16 +148,16 @@ lookupOrig mod occ -- which does some stuff that modifies the name cache -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) mod `seq` occ `seq` return () - ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) +-- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) ; name_cache <- getNameCache ; case lookupOrigNameCache (nsNames name_cache) mod occ of { - Just name -> returnM name; + Just name -> return name; Nothing -> let us = nsUniqs name_cache uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache (nsNames name_cache) mod occ name in case splitUniqSupply us of { (us',_) -> do @@ -172,15 +166,14 @@ lookupOrig mod occ }}} newIPName :: IPName OccName -> TcRnIf m n (IPName Name) -newIPName occ_name_ip - = getNameCache `thenM` \ name_supply -> +newIPName occ_name_ip = do + name_supply <- getNameCache 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 + Just name_ip -> return name_ip + Nothing -> do setNameCache new_ns + return name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 @@ -191,12 +184,17 @@ newIPName occ_name_ip key = occ_name_ip -- Ensures that ?x and %x get distinct Names \end{code} - Local helper functions (not exported) +%************************************************************************ +%* * + Name cache access +%* * +%************************************************************************ \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one, +lookupOrigNameCache _ mod occ + -- XXX Why is gHC_UNIT not mentioned here? + | mod == gHC_TUPLE || 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 @@ -205,7 +203,7 @@ lookupOrigNameCache nc mod occ mk_tup_name (ns, boxity, arity) | ns == tcName = tyConName (tupleTyCon boxity arity) | ns == dataName = dataConName (tupleCon boxity arity) - | otherwise = varName (dataConWorkId (tupleCon boxity arity)) + | otherwise = Var.varName (dataConWorkId (tupleCon boxity arity)) lookupOrigNameCache nc mod occ -- The normal case = case lookupModuleEnv nc mod of @@ -214,7 +212,8 @@ lookupOrigNameCache nc mod occ -- The normal case extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache nc name - = extendNameCache nc (nameModule name) (nameOccName name) name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name @@ -297,20 +296,30 @@ lookupIfaceTop :: OccName -> IfL Name lookupIfaceTop occ = do { env <- getLclEnv; lookupOrig (if_mod env) occ } -lookupHomePackage :: ModuleName -> OccName -> IfL Name -lookupHomePackage mod_name occ - = do { env <- getLclEnv; - ; let this_pkg = modulePackageId (if_mod env) - ; lookupOrig (mkModule this_pkg mod_name) occ } - newIfaceName :: OccName -> IfL Name newIfaceName occ = do { uniq <- newUnique - ; return $! mkInternalName uniq occ noSrcLoc } + ; return $! mkInternalName uniq occ noSrcSpan } newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs = do { uniqs <- newUniqueSupply - ; return [ mkInternalName uniq occ noSrcLoc + ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } \end{code} + +%************************************************************************ +%* * + (Re)creating tick boxes +%* * +%************************************************************************ + +\begin{code} +tcIfaceTick :: Module -> Int -> IfL Id +tcIfaceTick modName tickNo + = do { uniq <- newUnique + ; return $ mkTickBoxOpId uniq modName tickNo + } +\end{code} + +