From: sewardj Date: Tue, 17 Oct 2000 14:40:26 +0000 (+0000) Subject: [project @ 2000-10-17 14:40:26 by sewardj] X-Git-Tag: Approximately_9120_patches~3546 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=17879095049f5705c9734cab4f4c5d56f61f81a7;p=ghc-hetmet.git [project @ 2000-10-17 14:40:26 by sewardj] Make RnEnv compile. --- diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs index 90ef10c..7370668 100644 --- a/ghc/compiler/ghci/CompManager.lhs +++ b/ghc/compiler/ghci/CompManager.lhs @@ -26,7 +26,7 @@ import Finder ( Finder, newFinder, import CmSummarise ( summarise, ModSummary(..), mi_name, ms_get_imports, name_of_summary, deps_of_summary ) -import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile ) +--import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile ) import CmLink ( PLS, emptyPLS, Linkable(..), link, LinkResult(..), filterModuleLinkables, modname_of_linkable, diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 9a6dfd1..51126ef 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -10,9 +10,10 @@ module HscTypes ( TyThing(..), lookupTypeEnv, lookupFixityEnv, - WhetherHasOrphans, ImportVersion, ExportItem, + WhetherHasOrphans, ImportVersion, ExportItem, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, DeprecationEnv, OrigNameEnv, + IfaceInsts, IfaceRules, DeprecationEnv, + OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -61,6 +62,7 @@ import VarSet ( TyVarSet ) import Panic ( panic ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import Util ( thenCmp ) \end{code} %************************************************************************ @@ -360,9 +362,14 @@ we just store junk. Then when we find the binding site, we fix it up. \begin{code} data OrigNameEnv - = Orig { origNames :: FiniteMap (ModuleName,OccName) Name, -- Ensures that one original name gets one unique - origIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique + = Orig { origNames :: OrigNameNameEnv, + -- Ensures that one original name gets one unique + origIParam :: OrigNameIParamEnv + -- Ensures that one implicit parameter name gets one unique } + +type OrigNameNameEnv = FiniteMap (ModuleName,OccName) Name +type OrigNameIParamEnv = FiniteMap OccName Name \end{code} @@ -453,6 +460,29 @@ data Provenance ImportReason PrintUnqualified +-- Just used for grouping error messages (in RnEnv.warnUnusedBinds) +instance Eq Provenance where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImportReason where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord Provenance where + compare LocalDef LocalDef = EQ + compare LocalDef (NonLocalDef _ _) = LT + compare (NonLocalDef _ _) LocalDef = GT + + compare (NonLocalDef reason1 _) (NonLocalDef reason2 _) + = compare reason1 reason2 + +instance Ord ImportReason where + compare ImplicitImport ImplicitImport = EQ + compare ImplicitImport (UserImport _ _ _) = LT + compare (UserImport _ _ _) ImplicitImport = GT + compare (UserImport m1 loc1 _) (UserImport m2 loc2 _) + = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) + + {- Moved here from Name. pp_prov (LocalDef _ Exported) = char 'x' diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index f9ebbd1..c83a0f8 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -49,10 +49,11 @@ import IdInfo ( exactArity, InlinePragInfo(..) ) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex -import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..), - ExportItem, RdrAvailInfo, GenAvailInfo(..), - WhetherHasOrphans, IsBootInterface - ) +import RnMonad ( ParsedIface(..) ) +import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..), + ImportVersion, ExportItem, WhatsImported(..), + RdrAvailInfo ) + import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual ) import Name ( OccName ) import OccName ( mkSysOccFS, @@ -246,7 +247,7 @@ import_part : { [] } import_decl :: { ImportVersion OccName } import_decl : 'import' mod_name orphans is_boot whats_imported ';' - { (mkSysModuleNameFS $2, $3, $4, $5) } + { ({-mkSysModuleNameFS-} $2, $3, $4, $5) } orphans :: { WhetherHasOrphans } orphans : { False } @@ -275,7 +276,7 @@ name_version_pair : var_occ version { ($1, $2) } exports_part :: { [ExportItem] } exports_part : { [] } | '__export' mod_name entities ';' - exports_part { (mkSysModuleNameFS $2, $3) : $5 } + exports_part { ({-mkSysModuleNameFS-} $2, $3) : $5 } entities :: { [RdrAvailInfo] } entities : { [] } diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 8ed2072..0d99885 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -41,8 +41,6 @@ import PrelNames ( mkUnboundName ) import CmdLineOpts \end{code} - - %********************************************************* %* * \subsection{Making new names} @@ -50,8 +48,6 @@ import CmdLineOpts %********************************************************* \begin{code} -implicitImportProvenance = NonLocalDef ImplicitImport False - newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name newTopBinder mod rdr_name loc = -- First check the cache @@ -173,8 +169,8 @@ lookupTopBndrRn rdr_name getModuleRn `thenRn` \ mod -> getGlobalNameEnv `thenRn` \ global_env -> case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of - Just (name:rest) -> ASSERT( null rest ) - returnRn name + Just ((name,_):rest) -> ASSERT( null rest ) + returnRn name Nothing -> -- Almost always this case is a compiler bug. -- But consider a type signature that doesn't have -- a corresponding binder: @@ -221,8 +217,9 @@ lookupGlobalOccRn rdr_name getGlobalNameEnv `thenRn` \ global_env -> case lookupRdrEnv global_env rdr_name of Just [(name,_)] -> returnRn name - Just stuff@(_:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn rdr_name + Just stuff@((name,_):_) + -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name Nothing -> -- Not found when processing source code; so fail failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) @@ -512,9 +509,9 @@ combine_globals ns_old ns_new -- ns_new is often short (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm - is_duplicate :: Provenance -> (Name,Provenance) -> Bool - is_duplicate (n1,LocalDef _) (n2,LocalDef _) = False - is_duplicate n1 n2 = n1 == n2 + is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool + is_duplicate (n1,LocalDef) (n2,LocalDef) = False + is_duplicate (n1,_) (n2,_) = n1 == n2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -685,7 +682,7 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> warnUnusedModules :: [Module] -> RnM d () warnUnusedModules mods = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then mapRn_ (addWarnRn . unused_mod . moduleName) mods + if warn then mapRn_ (addWarnRn . unused_mod) mods else returnRn () where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> @@ -696,7 +693,7 @@ warnUnusedModules mods warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then warnUnusedBinds names else return () + if warn then warnUnusedBinds names else returnRn () warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () warnUnusedLocalBinds names @@ -717,15 +714,8 @@ warnUnusedBinds names where -- Group by provenance groups = equivClasses cmp names - (_,prov1) `cmp` (_,prov2) = prov1 `cmp_prov` prov2 + (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT - cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 - cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) - (NonLocalDef (UserImport m2 loc2 _) _) = - (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) - cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT - -- In-scope NonLocalDefs must have UserImport info on them ------------------------- @@ -736,13 +726,13 @@ warnUnusedGroup names | otherwise = pushSrcLocRn def_loc $ addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] where filtered_names = filter reportable names (name1, prov1) = head filtered_names (is_local, def_loc, msg) = case prov1 of - LocalDef loc _ -> (True, loc, text "Defined but not used") + LocalDef -> (True, getSrcLoc name1, text "Defined but not used") NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ad02e6d..7be1ba1 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -699,15 +699,15 @@ getInterfaceExports mod_name from = getHomeSymbolTableRn `thenRn` \ hst -> case lookupModuleEnvByName hst mod_name of { Just mds -> returnRn (mdModule mds, mdExports mds) ; - loadInterface doc_str mod_name from `thenRn` \ ifaces -> case lookupModuleEnv (iPST ifaces) mod_name of Just mds -> returnRn (mdModule mod, mdExports mds) -- loadInterface always puts something in the map -- even if it's a fake - where - doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] + } + where + doc_str = sep [pprModuleName mod_name, ptext SLIT("is directly imported")] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index f26bcf4..bdac32a 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -60,7 +60,8 @@ import UniqSupply import Outputable import Finder ( Finder ) import PrelNames ( mkUnboundName ) -import HscTypes ( GlobalSymbolTable, OrigNameEnv, AvailEnv, +import HscTypes ( GlobalSymbolTable, AvailEnv, + OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, WhetherHasOrphans, ImportVersion, ExportItem, PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, IfaceInsts, IfaceRules, DeprecationEnv, @@ -120,7 +121,9 @@ data RnDown rn_hst :: HomeSymbolTable, rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), - rn_ns :: IORef (UniqSupply, OrigNameEnv), + + -- The second and third components are a flattened-out OrigNameEnv + rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv), rn_ifaces :: IORef Ifaces } @@ -275,7 +278,8 @@ initRn dflags finder hst pcs mod loc do_rn = do let prs = pcs_PRS pcs uniqs <- mkSplitUniqSupply 'r' - names_var <- newIORef (uniqs, prsOrig prs) + names_var <- newIORef (uniqs, origNames (prsOrig prs), + origIParam (prsOrig prs)) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef (initIfaces pcs) let rn_down = RnDown { rn_mod = mod, @@ -294,11 +298,11 @@ initRn dflags finder hst pcs mod loc do_rn res <- do_rn rn_down () -- Grab state and record it - (warns, errs) <- readIORef errs_var - new_ifaces <- readIORef iface_var - (_, new_orig) <- readIORef names_var - - let new_prs = prs { prsOrig = new_orig, + (warns, errs) <- readIORef errs_var + new_ifaces <- readIORef iface_var + (_, new_origN, new_origIP) <- readIORef names_var + let new_orig = Orig { origNames = new_origN, origIParam = new_origIP } + let new_prs = prs { prsOrig = new_orig, prsDecls = iDecls new_ifaces, prsInsts = iInsts new_ifaces, prsRules = iRules new_ifaces } @@ -360,9 +364,10 @@ renameSourceCode dflags mod prs m -- only do any I/O if we need to read in a fixity declaration; -- and that doesn't happen in pragmas etc - mkSplitUniqSupply 'r' >>= \ new_us -> - newIORef (new_us, prsOrig prs) >>= \ names_var -> - newIORef (emptyBag,emptyBag) >>= \ errs_var -> + mkSplitUniqSupply 'r' >>= \ new_us -> + newIORef (new_us, origNames (prsOrig prs), + origIParam (prsOrig prs)) >>= \ names_var -> + newIORef (emptyBag,emptyBag) >>= \ errs_var -> let rn_down = RnDown { rn_dflags = dflags, rn_loc = generatedSrcLoc, rn_ns = names_var, @@ -551,21 +556,21 @@ getHomeSymbolTableRn down l_down = return (rn_hst down) %===================== \begin{code} -getNameSupplyRn :: RnM d (UniqSupply, OrigNameEnv) +getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) getNameSupplyRn rn_down l_down = readIORef (rn_ns rn_down) -setNameSupplyRn :: (UniqSupply, OrigNameEnv) -> RnM d () +setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d () setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeIORef names_var names' getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, {-cache,-} ipcache) -> + = readIORef names_var >>= \ (us, cache, ipcache) -> let (us1,us') = splitUniqSupply us in - writeIORef names_var (us', {-cache,-} ipcache) >> + writeIORef names_var (us', cache, ipcache) >> return (uniqFromSupply us1) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 694d07c..b5973f7 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -48,7 +48,7 @@ import Type ( tyVarsOfTypes, splitFunTy, applyTys, ) import TysWiredIn ( unitTy ) import VarSet ( intersectVarSet, isEmptyVarSet ) -import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name ) import ListSetOps ( equivClasses ) \end{code} @@ -263,8 +263,8 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - tcLookupGlobalId unpackCStringIdName `thenTc` \ unpack_id -> - tcLookupGlobalId unpackCStringUtf8IdName `thenTc` \ unpackUtf8_id -> + tcLookupGlobalId unpackCStringName `thenTc` \ unpack_id -> + tcLookupGlobalId unpackCStringUtf8Name `thenTc` \ unpackUtf8_id -> returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id) where field_ty = fieldLabelType first_field_label