X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=1ab14820a1814629d0b73f97bbbf0fc39e65b117;hb=624ff0c75af86ee06e1ada7b1944bba49832943d;hp=62312174be2d790df85499de1502dc309831499d;hpb=e921b2e307532e0f30eefa88b11a124be592bde4;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6231217..1ab1482 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,8 @@ import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName, + mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, + mkIPName, isSystemName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, occNameUserString, @@ -34,7 +35,7 @@ import OccName ( OccName, ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) import Type ( funTyCon ) -import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName ) +import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule ) import TyCon ( TyCon ) import FiniteMap import Unique ( Unique, Uniquable(..) ) @@ -56,14 +57,15 @@ import Maybes ( mapMaybe ) %********************************************************* \begin{code} +newImportedGlobalName :: ModuleName -> OccName -> Module -> RnM d Name newImportedGlobalName mod_name occ mod - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (mod_name, occ) in case lookupFM cache key of Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` returnRn name where (us', us1) = splitUniqSupply us @@ -73,8 +75,8 @@ newImportedGlobalName mod_name occ mod updateProvenances :: [Name] -> RnM d () updateProvenances names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - setNameSupplyRn (us, inst_ns, update cache names) + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + setNameSupplyRn (us, inst_ns, update cache names, ipcache) where update cache [] = cache update cache (name:names) = WARN( not (key `elemFM` cache), ppr name ) @@ -90,9 +92,9 @@ newImportedBinder mod rdr_name -- Make an imported global name, checking first to see if it's in the cache mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name mkImportedGlobalName mod_name occ - = lookupModuleRn mod_name `thenRn` \ mod -> - newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name) + = newImportedGlobalName mod_name occ (mkVanillaModule mod_name) +mkImportedGlobalFromRdrName :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name | isQual rdr_name = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) @@ -110,7 +112,7 @@ newLocalTopBinder :: Module -> OccName -> RnM d Name newLocalTopBinder mod occ rec_exp_fn loc = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (moduleName mod,occ) mk_prov name = LocalDef loc (rec_exp_fn name) @@ -134,7 +136,7 @@ newLocalTopBinder mod occ rec_exp_fn loc new_name = setNameProvenance name (mk_prov new_name) new_cache = addToFM cache key new_name in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` returnRn new_name -- Miss in the cache! @@ -145,8 +147,21 @@ newLocalTopBinder mod occ rec_exp_fn loc new_name = mkGlobalName uniq mod occ (mk_prov new_name) new_cache = addToFM cache key new_name in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` returnRn new_name + +getIPName rdr_name + = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> + case lookupFM ipcache key of + Just name -> returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_` + returnRn name + where + (us', us1) = splitUniqSupply us + uniq = uniqFromSupply us1 + name = mkIPName uniq key + new_ipcache = addToFM ipcache key name + where key = (rdrNameOcc rdr_name) \end{code} %********************************************************* @@ -214,7 +229,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope returnRn () ) `thenRn_` - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> getModeRn `thenRn` \ mode -> let n = length rdr_names_w_loc @@ -229,7 +244,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope -- Keep track of whether the name originally came from -- an interface file. in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` let new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) @@ -254,13 +269,13 @@ bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) bindCoreLocalFVRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` + setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in @@ -574,7 +589,7 @@ mkExportAvails mod_name unqual_imp name_env avails plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) + = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2) -- ToDo: wasteful: we do this once for each constructor! \end{code} @@ -583,12 +598,24 @@ plusExportAvails (m1, e1) (m2, e2) \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) +plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) -- Added SOF 4/97 #ifdef DEBUG plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) #endif +addAvail :: AvailEnv -> AvailInfo -> AvailEnv +addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail + +emptyAvailEnv = emptyNameEnv +unitAvailEnv :: AvailInfo -> AvailEnv +unitAvailEnv a = unitNameEnv (availName a) a + +plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv +plusAvailEnv = plusNameEnv_C plusAvail + +availEnvElts = nameEnvElts + addAvailToNameSet :: NameSet -> AvailInfo -> NameSet addAvailToNameSet names avail = addListToNameSet names (availNames avail) @@ -603,6 +630,10 @@ availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns +addSysAvails :: AvailInfo -> [Name] -> AvailInfo +addSysAvails avail [] = avail +addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) + filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; @@ -638,20 +669,12 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing +pprAvail :: AvailInfo -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of + [] -> empty + ns' -> parens (hsep (punctuate comma (map ppr ns'))) --- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail avail = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_avail (pprOccName . nameOccName) avail - else - ppr_avail ppr avail - -ppr_avail pp_name (AvailTC n ns) = hsep [ - pp_name n, - parens $ hsep $ punctuate comma $ - map pp_name ns - ] -ppr_avail pp_name (Avail n) = pp_name n +pprAvail (Avail n) = ppr n \end{code}