X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=b4bb690fff4490659f78dee519ab0d623a9dcd30;hb=266fadd93461d4317967df08cd641e965cd8769a;hp=f8dab26a12a189f4d336ce4c88c207f82139f351;hpb=4bb6e490454fe59f26ac656715d566dde8e9aa35;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index f8dab26..b4bb690 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, + mkIPName, isSystemName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, occNameUserString, @@ -29,7 +30,7 @@ import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ) import NameSet import OccName ( OccName, - mkDFunOcc, occNameUserString, + mkDFunOcc, occNameUserString, occNameString, occNameFlavour ) import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) @@ -57,13 +58,13 @@ import Maybes ( mapMaybe ) \begin{code} 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 +74,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,7 +91,8 @@ 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 - = newImportedGlobalName mod_name occ (mkVanillaModule mod_name) + = lookupModuleRn mod_name `thenRn` \ mod -> + newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name) mkImportedGlobalFromRdrName rdr_name | isQual rdr_name @@ -109,7 +111,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) @@ -133,7 +135,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! @@ -144,8 +146,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} %********************************************************* @@ -168,8 +183,11 @@ Make a name for the dict fun for an instance decl \begin{code} newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name newDFunName key@(cl_occ, tycon_occ) loc - = newInstUniq key `thenRn` \ inst_uniq -> - newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc + = newInstUniq string `thenRn` \ inst_uniq -> + newImplicitBinder (mkDFunOcc string inst_uniq) loc + where + -- Any string that is somewhat unique will do + string = occNameString cl_occ ++ occNameString tycon_occ \end{code} \begin{code} @@ -210,7 +228,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 @@ -225,7 +243,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) @@ -250,13 +268,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 @@ -289,6 +307,10 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- +bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) +bindUVarRn = bindLocalRn + +------------------------------------- extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope @@ -623,7 +645,10 @@ filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted -- import A( op ) -- where op is a class operation -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail +filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail + -- We don't complain even if the IE says T(..), but + -- no constrs/class ops of T are available + -- Instead that's caught with a warning by the caller filterAvail ie avail = Nothing @@ -686,18 +711,19 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ + \begin{code} -warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedTopNames names - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports - = returnRn () -- Don't force ns unless necessary +warnUnusedImports names + | not opt_WarnUnusedImports + = returnRn () -- Don't force names unless necessary | otherwise - = warnUnusedBinds (\ is_local -> not is_local) names + = warnUnusedBinds (const True) names warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds (\ is_local -> is_local) ns + | otherwise = warnUnusedBinds (const True) ns warnUnusedMatches names | opt_WarnUnusedMatches = warnUnusedGroup (const True) names @@ -723,6 +749,12 @@ warnUnusedBinds warn_when_local names ------------------------- +-- NOTE: the function passed to warnUnusedGroup is +-- now always (const True) so we should be able to +-- simplify the code slightly. I'm leaving it there +-- for now just in case I havn't realised why it was there. +-- Looks highly bogus to me. SLPJ Dec 99 + warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d () warnUnusedGroup emit_warning names | null filtered_names = returnRn () @@ -744,7 +776,7 @@ warnUnusedGroup emit_warning names reportable name = case occNameUserString (nameOccName name) of ('_' : _) -> False - _other -> True + zz_other -> True -- Haskell 98 encourages compilers to suppress warnings about -- unused names in a pattern if they start with "_". \end{code} @@ -786,4 +818,3 @@ dupNamesErr descriptor ((name,loc) : dup_things) $$ (ptext SLIT("in") <+> descriptor)) \end{code} -