From 9adbdb312507dcc7d5777e36376535918549103b Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 16 Oct 2000 08:24:20 +0000 Subject: [PATCH] [project @ 2000-10-16 08:24:18 by simonpj] Mainly renamer --- ghc/compiler/basicTypes/Name.lhs | 346 +++++++++++---------------------- ghc/compiler/basicTypes/SrcLoc.lhs | 36 ++-- ghc/compiler/coreSyn/CoreLint.lhs | 4 +- ghc/compiler/deSugar/DsForeign.lhs | 5 +- ghc/compiler/main/HscTypes.lhs | 141 +++++++++++--- ghc/compiler/rename/Rename.lhs | 47 +++-- ghc/compiler/rename/RnEnv.lhs | 215 ++++++++------------ ghc/compiler/rename/RnIfaces.lhs | 194 +++++++++--------- ghc/compiler/rename/RnMonad.lhs | 110 +++++------ ghc/compiler/rename/RnNames.lhs | 73 +++---- ghc/compiler/simplCore/SimplUtils.lhs | 2 +- ghc/compiler/typecheck/TcEnv.lhs | 4 +- ghc/compiler/types/TypeRep.lhs | 9 +- 13 files changed, 539 insertions(+), 647 deletions(-) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index aa72a0c..1410961 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -14,9 +14,9 @@ module Name ( mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInName, - nameUnique, setNameUnique, setNameProvenance, getNameProvenance, - setNameImportReason, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, + nameUnique, setNameUnique, setLocalNameSort, + tidyTopName, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModuleAndLoc, toRdrName, hashName, isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, @@ -34,11 +34,6 @@ module Name ( lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv, - -- Provenance - Provenance(..), ImportReason(..), pprProvenance, - ExportFlag(..), PrintUnqualified, - pprNameProvenance, hasBetterProv, - -- Class NamedThing and overloaded friends NamedThing(..), getSrcLoc, isLocallyDefined, getOccString, toRdrName @@ -71,25 +66,96 @@ import Outputable \begin{code} data Name = Name { n_sort :: NameSort, -- What sort of name it is - n_uniq :: Unique, n_occ :: OccName, -- Its occurrence name - n_prov :: Provenance -- How it was made + n_uniq :: Unique, + n_loc :: SrcLoc -- Definition site } data NameSort - = Local - | Global Module + = Global Module -- (a) TyCon, Class, their derived Ids, dfun Id + -- (b) imported Id + + | Exported -- An exported Ids defined in the module being compiled + + | Local -- A user-defined, but non-exported Id or TyVar, + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') \end{code} -Things with a @Global@ name are given C static labels, so they finally -appear in the .o file's symbol table. They appear in the symbol table -in the form M.n. If originally-local things have this property they -must be made @Global@ first. +Notes about the NameSorts: + +1. An Exported Id is changed to Global right at the + end in the tidyCore pass, so that an importer sees a Global + Similarly, Local Ids that are visible to an importer (e.g. when + optimisation is on) are changed to Globals. + +2. Things with a @Global@ name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @Global@ first. + +3. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +\begin{code} +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameSrcLoc name = n_loc name +nameModule (Name { n_sort = Global mod }) = mod +nameModule name = pprPanic "nameModule" (ppr name) +\end{code} + +\begin{code} +isLocallyDefinedName :: Name -> Bool +isUserExportedName :: Name -> Bool +isLocalName :: Name -> Bool -- Not globala +isGlobalName :: Name -> Bool +isSystemName :: Name -> Bool +isExternallyVisibleName :: Name -> Bool + +isGlobalName (Name {n_sort = Global _}) = True +isGlobalName other = False + +isLocalName name = not (isGlobalName name) + +isLocallyDefinedName name = isLocalName name + +-- Global names are by definition those that are visible +-- outside the module, *as seen by the linker*. Externally visible +-- does not mean visible at the source level (that's isExported). +isExternallyVisibleName name = isGlobalName name + +isUserExportedName (Name { n_sort = Exported }) = True +isUserExportedName other = False + +isSystemName (Name {n_sort = System}) = True +isSystemName other = False +\end{code} + + +%************************************************************************ +%* * +\subsection{Making names} +%* * +%************************************************************************ \begin{code} mkLocalName :: Unique -> OccName -> SrcLoc -> Name -mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, - n_prov = LocalDef loc NotExported } +mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok @@ -105,33 +171,35 @@ mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name -- file. This is useful when trying to decide which of two type -- variables should 'win' when unifying them. -- NB: this is only for non-top-level names, so we use ImplicitImport -mkImportedLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, - n_prov = NonLocalDef ImplicitImport True } + -- + -- Oct 00: now that Names lack Provenances, mkImportedLocalName doesn't make + -- sense any more, so it's just the same as mkLocalName +mkImportedLocalName uniq occ loc = mkLocalName uniq occ loc -mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name +mkGlobalName :: Unique -> Module -> OccName -> SrcLoc -> Name mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod, - n_occ = occ, n_prov = prov } + n_occ = occ, n_loc = loc } mkKnownKeyGlobal :: RdrName -> Unique -> Name mkKnownKeyGlobal rdr_name uniq = mkGlobalName uniq (mkVanillaModule (rdrNameModule rdr_name)) (rdrNameOcc rdr_name) - systemProvenance + builtinSrcLoc mkWiredInName :: Module -> OccName -> Unique -> Name -mkWiredInName mod occ uniq = mkGlobalName uniq mod occ systemProvenance +mkWiredInName mod occ uniq = mkGlobalName uniq mod occ builtinSrcLoc mkSysLocalName :: Unique -> UserFS -> Name -mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = Local, - n_occ = mkVarOcc fs, n_prov = systemProvenance } +mkSysLocalName uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkVarOcc fs, n_loc = noSrcLoc } mkCCallName :: Unique -> EncodedString -> Name -- The encoded string completely describes the ccall mkCCallName uniq str = Name { n_uniq = uniq, n_sort = Local, n_occ = mkCCallOcc str, - n_prov = NonLocalDef ImplicitImport True } + n_prov = noSrcLoc } mkTopName :: Unique -> Module -> FAST_STRING -> Name -- Make a top-level name; make it Global if top-level @@ -142,11 +210,12 @@ mkTopName :: Unique -> Module -> FAST_STRING -> Name -- We have to make sure that the name is globally unique -- and we don't have tidyCore to help us. So we append -- the unique. Hack! Hack! + -- (Used only by the STG lambda lifter.) mkTopName uniq mod fs = Name { n_uniq = uniq, n_sort = mk_top_sort mod, n_occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)), - n_prov = LocalDef noSrcLoc NotExported } + n_loc = noSrcLoc } mkIPName :: Unique -> OccName -> Name mkIPName uniq occ @@ -177,25 +246,31 @@ setNameOcc :: Name -> OccName -> Name -- This is used by the tidy-up pass setNameOcc name occ = name {n_occ = occ} -setNameModule :: Name -> Module -> Name -setNameModule name mod = name {n_sort = set (n_sort name)} +setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name +setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc} where - set (Global _) = Global mod + set (Global _) = Global mod + +setLocalNameSort :: Name -> Bool -> Name + -- Set the name's sort to Local or Exported, depending on the boolean +setLocalNameSort name is_exported = name { n_sort = if is_exported then Exported + else Local } \end{code} %************************************************************************ %* * -\subsection{Setting provenance and visibility +\subsection{Tidying a name} %* * %************************************************************************ tidyTopName is applied to top-level names in the final program -For top-level things, it globalises Local names - (if all top-level things should be visible) - and localises non-exported Global names - (if only exported things should be visible) +For top-level things, + it globalises Local names + (if all top-level things should be visible) + and localises non-exported Global names + (if only exported things should be visible) In all cases except an exported global, it gives it a new occurrence name. @@ -231,7 +306,7 @@ tidyTopName mod env name (env', occ') = tidyOccName env (n_occ name) name' = Name { n_uniq = n_uniq name, n_sort = mk_top_sort mod, - n_occ = occ', n_prov = LocalDef noSrcLoc NotExported } + n_occ = occ', n_loc = n_loc name } mk_top_sort mod | all_toplev_ids_visible = Global mod | otherwise = Local @@ -242,128 +317,6 @@ all_toplev_ids_visible = \end{code} -\begin{code} -setNameProvenance :: Name -> Provenance -> Name - -- setNameProvenance used to only change the provenance of - -- Implicit-provenance things, but that gives bad error messages - -- for names defined twice in the same module, so I changed it to - -- set the provenance of *any* global (SLPJ Jun 97) -setNameProvenance name prov = name {n_prov = prov} - -getNameProvenance :: Name -> Provenance -getNameProvenance name = n_prov name - -setNameImportReason :: Name -> ImportReason -> Name -setNameImportReason name reason - = name { n_prov = new_prov } - where - -- It's important that we don't do the pattern matching - -- in the top-level clause, else we get a black hole in - -- the renamer. Rather a yukky constraint. There's only - -- one call, in RnNames - old_prov = n_prov name - new_prov = case old_prov of - NonLocalDef _ omit -> NonLocalDef reason omit - other -> old_prov -\end{code} - - -%************************************************************************ -%* * -\subsection{Provenance and export info} -%* * -%************************************************************************ - -\begin{code} -data Provenance - = LocalDef -- Defined locally - SrcLoc -- Defn site - ExportFlag -- Whether it's exported - - | NonLocalDef -- Defined non-locally - ImportReason - PrintUnqualified - - | SystemProv -- Either (a) a system-generated local with - -- a v short name OccName - -- or (b) a known-key global which should have a proper - -- provenance attached by the renamer -\end{code} - -Sys-provs are only used internally. When the compiler generates (say) -a fresh desguar variable it always calls it "ds", and of course it gets -a fresh unique. But when printing -ddump-xx dumps, we must print it with -its unique, because there'll be a lot of "ds" variables. - -Names with SystemProv differ in the following ways: - a) locals have unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - c) renamer replaces SystemProv with a better one - -Before anything gets printed in interface files or output code, it's -fed through a 'tidy' processor, which zaps the OccNames to have -unique names; and converts all sys-locals to user locals -If any desugarer sys-locals have survived that far, they get changed to -"ds1", "ds2", etc. - -\begin{code} -data ImportReason - = UserImport Module SrcLoc Bool -- Imported from module M on line L - -- Note the M may well not be the defining module - -- for this thing! - -- The Bool is true iff the thing was named *explicitly* in the import spec, - -- rather than being imported as part of a group; e.g. - -- import B - -- import C( T(..) ) - -- Here, everything imported by B, and the constructors of T - -- are not named explicitly; only T is named explicitly. - -- This info is used when warning of unused names. - - | ImplicitImport -- Imported implicitly for some other reason - - -type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is - -- in scope in this module, so print it - -- unqualified in error messages - -data ExportFlag = Exported | NotExported -\end{code} - -Something is "Exported" if it may be mentioned by another module without -warning. The crucial thing about Exported things is that they must -never be dropped as dead code, even if they aren't used in this module. -Furthermore, being Exported means that we can't see all call sites of the thing. - -Exported things include: - - - explicitly exported Ids, including data constructors, - class method selectors - - - dfuns from instance decls - -Being Exported is *not* the same as finally appearing in the .o file's -symbol table. For example, a local Id may be mentioned in an Exported -Id's unfolding in the interface file, in which case the local Id goes -out too. - - -\begin{code} -systemProvenance :: Provenance -systemProvenance = SystemProv - --- pprNameProvenance is used in error messages to say where a name came from -pprNameProvenance :: Name -> SDoc -pprNameProvenance name = pprProvenance (getNameProvenance name) - -pprProvenance :: Provenance -> SDoc -pprProvenance SystemProv = ptext SLIT("System") -pprProvenance (LocalDef loc _) = ptext SLIT("defined at") <+> ppr loc -pprProvenance (NonLocalDef ImplicitImport _) - = ptext SLIT("implicitly imported") -pprProvenance (NonLocalDef (UserImport mod loc _) _) - = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc -\end{code} - %************************************************************************ %* * @@ -372,36 +325,15 @@ pprProvenance (NonLocalDef (UserImport mod loc _) _) %************************************************************************ \begin{code} -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameModule :: Name -> Module -nameSrcLoc :: Name -> SrcLoc -isLocallyDefinedName :: Name -> Bool -isUserExportedName :: Name -> Bool -isLocalName :: Name -> Bool -isGlobalName :: Name -> Bool -isExternallyVisibleName :: Name -> Bool - - - hashName :: Name -> Int hashName name = iBox (u2i (nameUnique name)) -nameUnique name = n_uniq name -nameOccName name = n_occ name - -nameModule name = - case n_sort name of - Local -> pprPanic "nameModule" (ppr name) - x -> nameSortModule x - -nameSortModule (Global mod) = mod nameRdrName :: Name -> RdrName -- Makes a qualified name for top-level (Global) names, whether locally defined or not -- and an unqualified name just for Locals -nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ -nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ +nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrQual (moduleName mod) occ +nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ ifaceNameRdrName :: Name -> RdrName -- Makes a qualified naem for imported things, @@ -409,63 +341,17 @@ ifaceNameRdrName :: Name -> RdrName ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n) | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n) -isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True -isUserExportedName other = False - -isUserImportedExplicitlyName (Name { n_prov = NonLocalDef (UserImport _ _ explicit) _ }) = explicit -isUserImportedExplicitlyName other = False - -isUserImportedName (Name { n_prov = NonLocalDef (UserImport _ _ _) _ }) = True -isUserImportedName other = False - -maybeUserImportedFrom (Name { n_prov = NonLocalDef (UserImport m _ _) _ }) = Just m -maybeUserImportedFrom other = Nothing - isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && - not (isLocallyDefinedName nm) && --- isLocallyDefinedName test is needed because nameModule won't work on local names - not (isLocalModule (nameModule nm)) - -nameSrcLoc name = provSrcLoc (n_prov name) + not (isLocallyDefinedName nm) && -- isLocallyDefinedName test needed 'cos + not (isLocalModule (nameModule nm)) -- nameModule won't work on local names -provSrcLoc (LocalDef loc _) = loc -provSrcLoc (NonLocalDef (UserImport _ loc _) _) = loc -provSrcLoc other = noSrcLoc - -isLocallyDefinedName (Name {n_sort = Local}) = True -- Local (might have SystemProv) -isLocallyDefinedName (Name {n_prov = LocalDef _ _}) = True -- Global, but defined here -isLocallyDefinedName other = False -- Other -isLocalName (Name {n_sort = Local}) = True -isLocalName _ = False - -isGlobalName (Name {n_sort = Local}) = False -isGlobalName other = True isTyVarName :: Name -> Bool isTyVarName name = isTvOcc (nameOccName name) --- Global names are by definition those that are visible --- outside the module, *as seen by the linker*. Externally visible --- does not mean visible at the source level (that's isExported). -isExternallyVisibleName name = isGlobalName name - -hasBetterProv :: Name -> Name -> Bool --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -hasBetterProv n1 n2 - = case (n_prov n1, n_prov n2) of - (LocalDef _ _, _ ) -> True - (NonLocalDef (UserImport _ _ True) _, _ ) -> True - (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True - other -> False - -isSystemName (Name {n_prov = SystemProv}) = True -isSystemName other = False \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 5eaf8e6..1c3cc68 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -11,15 +11,12 @@ module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, - noSrcLoc, isNoSrcLoc, -- "I'm sorry, I haven't a clue" + mkSrcLoc, isGoodSrcLoc, + noSrcLoc, -- "I'm sorry, I haven't a clue" - mkIfaceSrcLoc, -- Unknown place in an interface - -- (this one can die eventually ToDo) - - mkBuiltinSrcLoc, -- Something wired into the compiler - - mkGeneratedSrcLoc, -- Code generated within the compiler + importedSrcLoc, -- Unknown place in an interface + builtinSrcLoc, -- Something wired into the compiler + generatedSrcLoc, -- Code generated within the compiler incSrcLine, replaceSrcLine, @@ -46,12 +43,12 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = NoSrcLoc - - | SrcLoc FAST_STRING -- A precise location (file name) + = SrcLoc FAST_STRING -- A precise location (file name) FastInt | UnhelpfulSrcLoc FAST_STRING -- Just a general indication + + | NoSrcLoc \end{code} Note that an entity might be imported via more than one route, and @@ -67,15 +64,14 @@ rare case. Things to make 'em: \begin{code} -noSrcLoc = NoSrcLoc -mkSrcLoc x y = SrcLoc x (iUnbox y) - -mkIfaceSrcLoc = UnhelpfulSrcLoc SLIT("") -mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("") -mkGeneratedSrcLoc = UnhelpfulSrcLoc SLIT("") +mkSrcLoc x y = SrcLoc x (iUnbox y) +noSrcLoc = NoSrcLoc +importedSrcLoc = UnhelpfulSrcLoc SLIT("") +builtinSrcLoc = UnhelpfulSrcLoc SLIT("") +generatedSrcLoc = UnhelpfulSrcLoc SLIT("") -isNoSrcLoc NoSrcLoc = True -isNoSrcLoc other = False +isGoodSrcLoc (SrcLoc _ _) = True +isGoodSrcLoc other = False srcLocFile :: SrcLoc -> FAST_STRING srcLocFile (SrcLoc fname _) = fname @@ -137,6 +133,4 @@ instance Outputable SrcLoc where -- so emacs can find the file ppr (UnhelpfulSrcLoc s) = ptext s - - ppr NoSrcLoc = text "" \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 6bf156d..d07de86 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -586,9 +586,7 @@ addErr errs_so_far msg locs context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 | otherwise = cxt1 - mk_msg msg - | isNoSrcLoc loc = (loc, hang context 4 msg) - | otherwise = addErrLocHdrLine loc context msg + mk_msg msg = addErrLocHdrLine loc context msg addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs warns diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 3497cf2..ee7e668 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -27,7 +27,7 @@ import Literal ( Literal(..) ) import Module ( Module, moduleUserString ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, - NamedThing(..), Provenance(..), ExportFlag(..) + NamedThing(..), ) import Type ( unUsgTy, repType, splitTyConApp_maybe, splitFunTys, splitForAllTys, @@ -271,8 +271,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn | otherwise = nameModule name occ = mkForeignExportOcc (nameOccName name) - prov = LocalDef src_loc Exported - helper_name = mkGlobalName uniq mod occ prov + helper_name = mkGlobalName uniq mod occ src_loc the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args))) the_body = mkLams (tvs ++ wrapper_args) the_app diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c3cdf64..2138d48 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -4,12 +4,22 @@ \section[HscTypes]{Types for the per-module compiler} \begin{code} -module HscTypes ( TyThing(..), GlobalSymbolTable, OrigNameEnv, AvailEnv, - WhetherHasOrphans, ImportVersion, ExportItem, - PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, DeprecationEnv, ModDetails(..), - InstEnv, lookupTypeEnv ) -where +module HscTypes ( + ModDetails(..), GlobalSymbolTable, + + TyThing(..), lookupTypeEnv, + + WhetherHasOrphans, ImportVersion, ExportItem, + PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, + IfaceInsts, IfaceRules, DeprecationEnv, OrigNameEnv, AvailEnv, + + InstEnv, + + -- Provenance + Provenance(..), ImportReason(..), PrintUnqualified, + pprProvenance, hasBetterProv + + ) where #include "HsVersions.h" @@ -57,6 +67,7 @@ data ModDetails = ModDetails { moduleId :: Module, moduleExports :: Avails, -- What it exports + mdVersion :: VersionInfo, moduleEnv :: GlobalRdrEnv, -- Its top level environment fixityEnv :: NameEnv Fixity, @@ -92,14 +103,12 @@ type GlobalSymbolTable = SymbolTable -- Domain = all modules Simple lookups in the symbol table. \begin{code} -lookupFixityEnv :: SymbolTable -> Name -> Fixity +lookupFixityEnv :: SymbolTable -> Name -> Maybe Fixity -- Returns defaultFixity if there isn't an explicit fixity lookupFixityEnv tbl name = case lookupModuleEnv tbl (nameModule name) of - Nothing -> defaultFixity - Just details -> case lookupNameEnv (fixityEnv details) name of - Just fixity -> fixity - Nothing -> defaultFixity + Nothing -> Nothing + Just details -> lookupNameEnv (fixityEnv details) name \end{code} @@ -170,11 +179,15 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation +data VersionInfo + = VersionInfo { + modVers :: Version, + fixVers :: Version, + ruleVers :: Version, + declVers :: NameEnv Version + } -type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes - -- These only get reported on lookup, - -- not on construction +type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class @@ -264,7 +277,6 @@ data WhatsImported name = NothingAtAll -- The module is below us in the -- 'Everything' means there was a "module M" in -- this module's export list, so we just have to go by M's version, -- not the list of (name,version) pairs - \end{code} @@ -313,16 +325,34 @@ data PersistentRenamerState prsInsts :: IfaceInsts, prsRules :: IfaceRules } +\end{code} + +The OrigNameEnv makes sure that there is just one Unique assigned for +each original name; i.e. (module-name, occ-name) pair. The Name is +always stored as a Global, and has the SrcLoc of its binding location. +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. + +Exactly the same is true of the Module stored in the Name. When we first +encounter the occurrence, we may not know the details of the module, so +we just store junk. Then when we find the binding site, we fix it up. +\begin{code} data OrigNameEnv - = Orig { origNames :: FiniteMap (Module,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 :: 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 } +\end{code} -type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) - -- A DeclsMap contains a binding for each Name in the declaration - -- including the constructors of a type decl etc. - -- The Bool is True just for the 'main' Name. + +A DeclsMap contains a binding for each Name in the declaration +including the constructors of a type decl etc. The Bool is True just +for the 'main' Name. + +\begin{code} +type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameHsDecl)) type IfaceInsts = Bag GatedDecl type IfaceRules = Bag GatedDecl @@ -379,3 +409,70 @@ type HomeInterfaceTable = ModuleEnv ModIFace \end{code} +%************************************************************************ +%* * +\subsection{Provenance and export info} +%* * +%************************************************************************ + +The GlobalRdrEnv gives maps RdrNames to Names. There is a separate +one for each module, corresponding to that module's top-level scope. + +\begin{code} +type GlobalRdrEnv = RdrNameEnv [(Name,Provenance)] -- The list is because there may be name clashes + -- These only get reported on lookup, + -- not on construction +\end{code} + +The "provenance" of something says how it came to be in scope. + +\begin{code} +data Provenance + = LocalDef -- Defined locally + + | NonLocalDef -- Defined non-locally + ImportReason + PrintUnqualified + +data ImportReason + = UserImport Module SrcLoc Bool -- Imported from module M on line L + -- Note the M may well not be the defining module + -- for this thing! + -- The Bool is true iff the thing was named *explicitly* in the import spec, + -- rather than being imported as part of a group; e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- This info is used when warning of unused names. + + | ImplicitImport -- Imported implicitly for some other reason + + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it + -- unqualified in error messages +\end{code} + +\begin{code} +hasBetterProv :: Provenance -> Provenance -> Bool +-- Choose +-- a local thing over an imported thing +-- a user-imported thing over a non-user-imported thing +-- an explicitly-imported thing over an implicitly imported thing +hasBetterProv LocalDef _ = True +hasBetterProv (NonLocalDef (UserImport _ _ True) _) _ = True +hasBetterProv (NonLocalDef (UserImport _ _ _ ) _) (NonLocalDef ImplicitImport _) = True +hasBetterProv _ _ = False + +pprNameProvenance :: Name -> Provenance -> SDoc +pprProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprProvenance name (NonLocalDef why _) = sep [ppr_reason why, + nest 2 (parens (ppr_defn (nameSrcLoc name)))] + +ppr_reason ImplicitImport = ptext SLIT("implicitly imported") +ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc + +ppr_defn loc | isGoodSrcLoc loc = ptext SLIT("at") <+> ppr loc + | otherwise = empty +\end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c919986..cf67969 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -72,24 +72,20 @@ import IO ( openFile, IOMode(..) ) \begin{code} -type RenameResult = ( Module -- This module +type RenameResult = ( PersistentCompilerState, + , Module -- This module , RenamedHsModule -- Renamed module , Maybe ParsedIface -- The existing interface file, if any , ParsedIface -- The new interface - , RnNameSupply -- Final env; for renaming derivings - , FixityEnv -- The fixity environment; for derivings , [Module]) -- Imported modules -renameModule :: PersistentCompilerState -> GlobalSymbolTable +renameModule :: PersistentCompilerState -> HomeSymbolTable -> RdrNameHsModule -> IO (Maybe RenameResult) -renameModule pcs gst this_mod@(HsModule mod_name vers exports imports local_decls _ loc) +renameModule old_pcs hst this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad do { - ((maybe_rn_stuff, dump_action), msgs) - <- initRn dflags finder gst prs - (mkThisModule mod_name) - (mkSearchPath opt_HiMap) loc - (rename this_mod) ; + ((maybe_rn_stuff, dump_action), msgs, new_pcs) + <- initRn dflags finder old_pcs hst loc (rename this_mod) ; -- Check for warnings printErrorsAndWarnings msgs ; @@ -99,9 +95,9 @@ renameModule pcs gst this_mod@(HsModule mod_name vers exports imports local_decl -- Return results if not (isEmptyBag rn_errs_bag) then - do { ghcExit 1 ; return Nothing } + return (old_pcs, Nothing) else - return maybe_rn_stuff + return (new_pcs, maybe_rn_stuff) } \end{code} @@ -622,7 +618,7 @@ fixitiesFromLocalDecls gbl_env decls `thenRn_` returnRn acc | otherwise -> returnRn acc ; - Just (name:_) -> + Just ((name,_):_) -> -- Check for duplicate fixity decl case lookupNameEnv acc name of { @@ -712,14 +708,18 @@ reportUnusedNames mod_name direct_import_mods , case parent_avail of { AvailTC _ _ -> True; other -> False } ] - defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) - defined_but_not_used = - nameSetToList (defined_names `minusNameSet` really_used_names) + defined_names, defined_but_not_used :: [(Name,Provenance)] + defined_names = concat (rdrEnvElts gbl_env) + defined_but_not_used = filter not_used defined_names + not_used name = not (name `elemNameSet` really_used_names) -- Filter out the ones only defined implicitly - bad_locals = [n | n <- defined_but_not_used, isLocallyDefined n] - bad_imp_names = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n, - not (module_unused n)] + bad_locals :: [Name] + bad_locals = [n | (n,LocalDef) <- defined_but_not_used] + + bad_imp_names :: [(Name,Provenance)] + bad_imp_names = [(n,p) | (n,p@(UserImport mod _ True) <- defined_but_not_used, + not (module_unused mod)] deprec_used deprec_env = [ (n,txt) | n <- nameSetToList mentioned_names, @@ -774,12 +774,9 @@ reportUnusedNames mod_name direct_import_mods not (maybeToBool (lookupFM minimal_imports m)), moduleName m /= pRELUDE_Name] - module_unused :: Name -> Bool - -- Name is imported from a module that's completely unused, - -- so don't report stuff about the name (the module covers it) - module_unused n = expectJust "module_unused" (maybeUserImportedFrom n) - `elem` unused_imp_mods - -- module_unused is only called if it's user-imported + module_unused :: Module -> Bool + module_unused mod = mod `elem` unused_imp_mods + in warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 5239c53..6d212cc 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -16,14 +16,13 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, mkRdrUnqual, qualifyRdrName ) import HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName ) - +import HscTypes ( pprNameProvenance ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, mkIPName, hasBetterProv, isLocallyDefined, nameOccName, setNameModule, nameModule, - setNameProvenance, getNameProvenance, pprNameProvenance, extendNameEnv_C, plusNameEnv_C, nameEnvElts ) import NameSet @@ -50,38 +49,27 @@ import List ( nub ) \begin{code} implicitImportProvenance = NonLocalDef ImplicitImport False -newTopBinder :: Module -> OccName -> RnM d Name -newTopBinder mod occ +newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name +newTopBinder mod rdr_name loc = -- First check the cache traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_` getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> let + occ = rdrNameOcc rdr_name key = (moduleName mod, occ) in case lookupFM cache key of - -- A hit in the cache! We are at the binding site of the name, which is - -- the time we know all about the Name's host Module (in particular, which - -- package it comes from), so update the Module in the name. - -- But otherwise *leave the Provenance alone*: - -- - -- * For imported names, the Provenance may already be correct. - -- e.g. We imported Prelude.hi, and set the provenance of PrelShow.Show - -- to 'UserImport from Prelude'. Note that we havn't yet opened PrelShow.hi - -- Later we find we really need PrelShow.Show, so we open PrelShow.hi, and - -- that's when we find the binding occurrence of Show. - -- - -- * For locally defined names, we do a setProvenance on the Name - -- right after newTopBinder, and then use updateProveances to finally - -- set the provenances in the cache correctly. - -- - -- NB: for wired-in names it's important not to - -- forget that they are wired in even when compiling that module - -- (else we spit out redundant defns into the interface file) + -- A hit in the cache! We are at the binding site of the name, and + -- this is the moment when we know all about + -- a) the Name's host Module (in particular, which + -- package it comes from) + -- b) its defining SrcLoc + -- So we update this info Just name -> let - new_name = setNameModule name mod + new_name = setNameModuleAndLoc name mod loc new_cache = addToFM cache key new_name in setNameSupplyRn (us, new_cache, ipcache) `thenRn_` @@ -95,7 +83,7 @@ newTopBinder mod occ Nothing -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ implicitImportProvenance + new_name = mkGlobalName uniq mod occ loc new_cache = addToFM cache key new_name in setNameSupplyRn (us', new_cache, ipcache) `thenRn_` @@ -106,8 +94,8 @@ newTopBinder mod occ newGlobalName :: ModuleName -> OccName -> RnM d Name -- Used for *occurrences*. We make a place-holder Name, really just -- to agree on its unique, which gets overwritten when we read in - -- the binding occurence later (newImportedBinder) - -- The place-holder Name doesn't have the right Provenance, and its + -- the binding occurence later (newTopBinder) + -- The place-holder Name doesn't have the right SrcLoc, and its -- Module won't have the right Package either. -- -- (We have to pass a ModuleName, not a Module, because we may be @@ -137,10 +125,9 @@ newGlobalName mod_name occ (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 mod = mkVanillaModule mod_name - name = mkGlobalName uniq mod occ implicitImportProvenance + name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name - newIPName rdr_name = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> case lookupFM ipcache key of @@ -153,34 +140,6 @@ newIPName rdr_name name = mkIPName uniq key new_ipcache = addToFM ipcache key name where key = (rdrNameOcc rdr_name) - -updateProvenances :: [Name] -> RnM d () --- Update the provenances of everything that is in scope. --- We must be careful not to disturb the Module package info --- already in the cache. Why not? Consider --- module A module M( f ) --- import M( f ) import N( f) --- import N --- So f is defined in N, and M re-exports it. --- When processing module A: --- 1. We read M.hi first, and make a vanilla name N.f --- (without reading N.hi). The package info says --- for lack of anything better. --- 2. Now we read N, which update the cache to record --- the correct package for N.f. --- 3. Finally we update provenances (once we've read all imports). --- Step 3 must not destroy package info recorded in Step 2. - -updateProvenances names - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> - setNameSupplyRn (us, foldr update cache names, ipcache) - where - update name cache = addToFM_C update_prov cache key name - where - key = (moduleName (nameModule name), nameOccName name) - - update_prov name_in_cache name_with_prov - = setNameProvenance name_in_cache (getNameProvenance name_with_prov) \end{code} %********************************************************* @@ -258,9 +217,9 @@ lookupGlobalOccRn rdr_name getGlobalNameEnv `thenRn` \ global_env -> case lookupRdrEnv global_env rdr_name of - Just [name] -> returnRn name - Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name + Just [(name,_)] -> returnRn name + Just stuff@(_:_) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name Nothing -> -- Not found when processing source code; so fail failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) @@ -314,29 +273,11 @@ or instance. \begin{code} lookupSysBinder rdr_name = ASSERT( isUnqual rdr_name ) - getModuleRn `thenRn` \ mod -> - newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> - getModeRn `thenRn` \ mode -> - case mode of - SourceMode -> getSrcLocRn `thenRn` \ loc -> - returnRn (setNameProvenance name (LocalDef loc Exported)) - InterfaceMode -> returnRn name + getModuleRn `thenRn` \ mod -> + getSrcLocRn `thenRn` \ loc -> + newTopBinder mod rdr_name loc \end{code} -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. - -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool -unQualInScope env - = lookup - where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [name'] -> name == name' - other -> False -\end{code} %********************************************************* @@ -538,38 +479,37 @@ checkDupNames doc_str rdr_names_w_loc %************************************************************************ %* * -\subsection{Envt utility functions} +\subsection{GlobalRdrEnv} %* * %************************************************************************ -\subsubsection{NameEnv}% ================ - \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [Name] -- Old - -> [Name] -- New - -> [Name] +combine_globals :: [(Name,Provenance)] -- Old + -> [(Name,Provenance)] -- New + -> [(Name,Provenance)] combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where - add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates + add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates | otherwise = n:ns - where - choose m | n==m && n `hasBetterProv` m = n - | otherwise = m + choose n m | n `beats` m = n + | otherwise = m + + (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm -is_duplicate :: Name -> Name -> Bool -is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False - | otherwise = n1 == n2 + is_duplicate :: Provenance -> (Name,Provenance) -> Bool + is_duplicate (n1,LocalDef _) (n2,LocalDef _) = False + is_duplicate _ _ = n1 == n2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -577,7 +517,7 @@ because they might be two separate, local defns and we want to report and error for that, {\em not} eliminate a duplicate. On the other hand, if you import the same name from two different -import statements, we {\em d}* want to eliminate the duplicate, not report +import statements, we {\em do} want to eliminate the duplicate, not report an error. If a module imports itself then there might be a local defn and an imported @@ -585,8 +525,27 @@ defn of the same name; in this case the names will compare as equal, but will still have different provenances. +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +unQualInScope env + = lookup + where + lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of + Just [(name',_)] -> name == name' + other -> False +\end{code} + -\subsubsection{AvailInfo}% ================ +%************************************************************************ +%* * +\subsection{Avails} +%* * +%************************************************************************ \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 @@ -676,8 +635,6 @@ pprAvail (Avail n) = ppr n \end{code} - - %************************************************************************ %* * \subsection{Free variable manipulation} @@ -719,8 +676,6 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %* * %************************************************************************ - - \begin{code} warnUnusedModules :: [Module] -> RnM d () warnUnusedModules mods @@ -732,30 +687,31 @@ warnUnusedModules mods parens (ptext SLIT("except perhaps to re-export instances visible in") <+> quotes (pprModuleName m))] -warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d () +warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names | not opt_WarnUnusedImports = returnRn () -- Don't force names unless necessary | otherwise - = warnUnusedBinds (const True) names + = warnUnusedBinds names +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds (const True) ns + | otherwise = warnUnusedBinds [(n,LocalDef) | n<-ns] warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedGroup (const True) names + | opt_WarnUnusedMatches = warnUnusedGroup [(n,LocalDef) | n<-ns] | otherwise = returnRn () ------------------------- -warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d () -warnUnusedBinds warn_when_local names - = mapRn_ (warnUnusedGroup warn_when_local) groups +warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds names + = mapRn_ warnUnusedGroup groups where -- Group by provenance groups = equivClasses cmp names - name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2 + (_,prov1) `cmp` (_,prov2) = prov1 `cmp_prov` prov2 cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 @@ -767,46 +723,39 @@ 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 () - | not (emit_warning is_local) = returnRn () +warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup names + | null filtered_names = returnRn () + | not is_local = returnRn () | otherwise = pushSrcLocRn def_loc $ addWarnRn $ sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] where filtered_names = filter reportable names - name1 = head filtered_names + (name1, prov1) = head filtered_names (is_local, def_loc, msg) - = case getNameProvenance name1 of - LocalDef loc _ -> (True, loc, text "Defined but not used") - NonLocalDef (UserImport mod loc _) _ -> - (True, loc, text "Imported from" <+> quotes (ppr mod) <+> - text "but not used") - other -> (False, getSrcLoc name1, text "Strangely defined but not used") - - reportable name = case occNameUserString (nameOccName name) of - ('_' : _) -> False - zz_other -> True + = case prov1 of + LocalDef loc _ -> (True, loc, text "Defined but not used") + + NonLocalDef (UserImport mod loc _) _ + -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") + + reportable (name,_) = case occNameUserString (nameOccName name) of + ('_' : _) -> False + zz_other -> True -- Haskell 98 encourages compilers to suppress warnings about -- unused names in a pattern if they start with "_". \end{code} \begin{code} -addNameClashErrRn rdr_name (name1:names) +addNameClashErrRn rdr_name (np1:nps) = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where - msg1 = ptext SLIT("either") <+> mk_ref name1 - msgs = [ptext SLIT(" or") <+> mk_ref name | name <- names] - mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name + msg1 = ptext SLIT("either") <+> mk_ref np1 + msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] + mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 62e7ba8..b724e37 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -107,27 +107,25 @@ tryLoadInterface doc_str mod_name from mod_map = iImpModInfo ifaces mod_info = lookupFM mod_map mod_name - hi_boot_file = case from of { - ImportByUser -> False ; -- Not hi-boot - ImportByUserSource -> True ; -- hi-boot - ImportBySystem -> - case mod_info of - Just (_, is_boot, _) -> is_boot - - Nothing -> False - -- We're importing a module we know absolutely - -- nothing about, so we assume it's from - -- another package, where we aren't doing - -- dependency tracking. So it won't be a hi-boot file. - } + hi_boot_file + = case (from, mod_info) of + (ImportByUser, _) -> False -- Not hi-boot + (ImportByUserSource, _) -> True -- hi-boot + (ImportBySystem, Just (_, is_boot, _)) -> is_boot -- + (ImportBySystem, Nothing) -> False + -- We're importing a module we know absolutely + -- nothing about, so we assume it's from + -- another package, where we aren't doing + -- dependency tracking. So it won't be a hi-boot file. + redundant_source_import = case (from, mod_info) of (ImportByUserSource, Just (_,False,_)) -> True - other -> False + other -> False in -- CHECK WHETHER WE HAVE IT ALREADY case mod_info of { - Just (_, _, Just _) + Just (_, _, True) -> -- We're read it already so don't re-read it returnRn (ifaces, Nothing) ; @@ -140,20 +138,19 @@ tryLoadInterface doc_str mod_name from (warnRedundantSourceImport mod_name) `thenRn_` -- READ THE MODULE IN - findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_result -> + findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_resultb -> case read_result of { Left err -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again let - mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, [])) + new_mod_map = addToFM mod_map mod_name (False, False, True) new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` returnRn (new_ifaces, Just err) ; -- Found and parsed! - Right iface -> + Right (mod, iface) -> -- LOAD IT INTO Ifaces @@ -162,43 +159,45 @@ tryLoadInterface doc_str mod_name from -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - getModuleRn `thenRn` \ this_mod -> - let - mod = pi_mod iface - in + -- Sanity check. If we're system-importing a module we know nothing at all -- about, it should be from a different package to this one WARN( not (maybeToBool mod_info) && case from of { ImportBySystem -> True; other -> False } && isLocalModule mod, ppr mod ) - foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls -> + + loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> + loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> + loadFixDecls mod_name (pi_fixity iface) `thenRn` \ (fix_vers, fix_env) -> + foldlRn (loadDeprec mod) emptyDeprecEnv (pi_deprecs iface) `thenRn` \ deprec_env -> foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules -> - loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities -> - foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs -> - mapRn (loadExport this_mod) (pi_exports iface) `thenRn` \ avails_s -> + loadExports (pi_exports iface) `thenRn` \ avails -> let + version = VersionInfo { modVers = pi_vers iface, + fixVers = fix_vers, + ruleVers = rule_vers, + declVers = decl_vers } + -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted -- from its usage info. mod_map1 = case from of ImportByUser -> addModDeps mod (pi_usages iface) mod_map other -> mod_map + mod_map2 = addToFM mod_map1 mod_name (pi_orphan iface, hi_boot_file, True) - -- Now add info about this module - mod_map2 = addToFM mod_map1 mod_name mod_details - cts = (pi_mod iface, pi_vers iface, - fst (pi_fixity iface), fst (pi_rules iface), - from, concat avails_s) - mod_details = (pi_orphan iface, hi_boot_file, Just cts) + -- Now add info about this module to the PST + new_pst = extendModuleEnv pst mod mod_detils + mod_details = ModDetails { mdModule = mod, mvVersion = version, + mdExports = avails, + mdFixEnv = fix_env, mdDeprecEnv = deprec_env } - new_ifaces = ifaces { iImpModInfo = mod_map2, + new_ifaces = ifaces { iPST = new_pst, iDecls = new_decls, - iFixes = new_fixities, iInsts = new_insts, iRules = new_rules, - iDeprecs = new_deprecs } + iImpModInfo = mod_map2 } in setIfacesRn new_ifaces `thenRn_` returnRn (new_ifaces, Nothing) @@ -209,7 +208,7 @@ tryLoadInterface doc_str mod_name from -- import decls in the interface file ----------------------------------------------------- -addModDeps :: Module -> [ImportVersion a] +addModDeps :: Module -> PackageSymbolTable -> [ImportVersion a] -> ImportedModuleInfo -> ImportedModuleInfo -- (addModDeps M ivs deps) -- We are importing module M, and M.hi contains 'import' decls given by ivs @@ -219,26 +218,34 @@ addModDeps mod new_deps mod_deps -- Don't record dependencies when importing a module from another package -- Except for its descendents which contain orphans, -- and in that case, forget about the boot indicator + filtered_new_deps :: (ModuleName, (WhetherHasOrphans, IsBootInterface)) filtered_new_deps - | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing)) + | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, False)) | (imp_mod, has_orphans, is_boot, _) <- new_deps ] - | otherwise = [ (imp_mod, (True, False, Nothing)) + | otherwise = [ (imp_mod, (True, False, False)) | (imp_mod, has_orphans, _, _) <- new_deps, has_orphans ] add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep - combine old@(_, old_is_boot, cts) new - | maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded + combine old@(_, old_is_boot, old_is_loaded) new + | old_is_loaded || not old_is_boot = old -- Keep the old info if it's already loaded -- or if it's a non-boot pending load - | otherwise = new -- Otherwise pick new info + | otherwise = new -- Otherwise pick new info ----------------------------------------------------- -- Loading the export list ----------------------------------------------------- +loadExports :: [ExportItem] -> RnM d Avails +loadExports items + = getModuleRn `thenRn` \ this_mod -> + mapRn (loadExport this_mod) items `thenRn` \ avails_s -> + returnRn (concat avails_s) + + loadExport :: Module -> ExportItem -> RnM d [AvailInfo] loadExport this_mod (mod, entities) | mod == moduleName this_mod = returnRn [] @@ -276,16 +283,22 @@ loadExport this_mod (mod, entities) -- Loading type/class/value decls ----------------------------------------------------- +loadDecls :: Module + -> DeclsMap + -> [(Version, RdrNameHsDecl)] + -> RnM d (NameEnv Version, DeclsMap) +loadDecls mod decls_map decls + = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls + loadDecl :: Module - -> DeclsMap + -> (NameEnv Version, DeclsMap) -> (Version, RdrNameHsDecl) - -> RnM d DeclsMap - -loadDecl mod decls_map (version, decl) + -> RnM d (NameEnv Version, DeclsMap) +loadDecl mod (version_map, decls_map) (version, decl) = getDeclBinders new_name decl `thenRn` \ maybe_avail -> case maybe_avail of { - Nothing -> returnRn decls_map; -- No bindings - Just avail -> + Nothing -> returnRn (version_map, decls_map); -- No bindings + Just avail -> getDeclSysBinders new_name decl `thenRn` \ sys_bndrs -> let @@ -296,13 +309,15 @@ loadDecl mod decls_map (version, decl) main_name = availName avail new_decls_map = foldl add_decl decls_map - [ (name, (version, full_avail, name==main_name, (mod, decl'))) + [ (name, (full_avail, name==main_name, (mod, decl'))) | name <- availNames full_avail] add_decl decls_map (name, stuff) = WARN( name `elemNameEnv` decls_map, ppr name ) extendNameEnv decls_map name stuff + + new_version_map = extendNameEnv version_map main_name version in - returnRn new_decls_map + returnRn (new_version_map, new_decls_map) } where -- newTopBinder puts into the cache the binder with the @@ -311,7 +326,7 @@ loadDecl mod decls_map (version, decl) -- There maybe occurrences that don't have the correct Module, but -- by the typechecker will propagate the binding definition to all -- the occurrences, so that doesn't matter - new_name rdr_name loc = newTopBinder mod (rdrNameOcc rdr_name) + new_name rdr_name loc = newTopBinder mod rdr_name loc {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, @@ -338,12 +353,12 @@ loadDecl mod decls_map (version, decl) -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod_name fixity_env (version, decls) - | null decls = returnRn fixity_env +loadFixDecls mod_name (version, decls) + | null decls = returnRn (version, emptyNameEnv) | otherwise = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> - returnRn (extendNameEnvList fixity_env to_add) + returnRn (version, mkNameEnv to_add) loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> @@ -395,14 +410,14 @@ removeFuns ty = ty loadRules :: Module -> IfaceRules -> (Version, [RdrNameRuleDecl]) - -> RnM d IfaceRules + -> RnM d (Version, IfaceRules) loadRules mod rule_bag (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn rule_bag + = returnRn (version, rule_bag) | otherwise = setModuleRn mod $ mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (rule_bag `unionBags` listToBag new_rules) + returnRn (version, rule_bag `unionBags` listToBag new_rules) loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl -- "Gate" the rule simply by whether the rule variable is @@ -561,9 +576,13 @@ data ImportDeclResult | HereItIs (Module, RdrNameHsDecl) importDecl name - = getSlurped `thenRn` \ already_slurped -> - if name `elemNameSet` already_slurped then - returnRn AlreadySlurped -- Already dealt with + = getIfacesRn `thenRn` \ ifaces -> + getHomeSymbolTableRn `thenRn` \ hst -> + if name `elemNameSet` iSlurp ifaces + || inTypeEnv (iPST ifaces) name + || inTypeEnv hst name + then -- Already dealt with + returnRn AlreadySlurped else if isLocallyDefined name then -- Don't bring in decls from -- the renamed module's own interface file @@ -580,21 +599,6 @@ importDecl name where doc = ptext SLIT("need home module for wired in thing") <+> ppr name - -{- I don't think this is necessary any more; SLPJ May 00 - load_home name - | name `elemNameSet` source_binders = returnRn () - -- When compiling the prelude, a wired-in thing may - -- be defined in this module, in which case we don't - -- want to load its home module! - -- Using 'isLocallyDefined' doesn't work because some of - -- the free variables returned are simply 'listTyCon_Name', - -- with a system provenance. We could look them up every time - -- but that seems a waste. - | otherwise = loadHomeInterface doc name `thenRn_` - returnRn () --} - getNonWiredInDecl :: Name -> RnMG ImportDeclResult getNonWiredInDecl needed_name = traceRn doc_str `thenRn_` @@ -778,7 +782,7 @@ lookupFixityRn :: Name -> RnMS Fixity lookupFixityRn name | isLocallyDefined name = getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupFixity local_fix_env name) + returnRn (lookupLocalFixity local_fix_env name) | otherwise -- Imported -- For imported names, we have to get their fixities by doing a loadHomeInterface, @@ -789,7 +793,10 @@ lookupFixityRn name -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. = loadHomeInterface doc name `thenRn` \ ifaces -> - returnRn (lookupFixity (iFixes ifaces) name) + getHomeSymbolTableRn `thenRn` \ hst -> + returnRn (lookupFixityEnv hst name `orElse` + lookupFixityEnv (iPST ifaces) name) `orElse` + defaultFixity) where doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -1110,7 +1117,7 @@ getDeclSysBinders new_name other_decl findAndReadIface :: SDoc -> ModuleName -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> RnM d (Either Message ParsedIface) + -> RnM d (Either Message (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -1120,16 +1127,18 @@ findAndReadIface doc_str mod_name hi_boot_file -- one for 'normal' ones, the other for .hi-boot files, -- hence the need to signal which kind we're interested. - getFinderRn `thenRn` \ finder -> - ioToRn (finder mod_name) `thenRn` \ maybe_module -> + getFinderRn `thenRn` \ finder -> + ioToRn (findModule finder mod_name) `thenRn` \ maybe_module -> + case maybe_module of - -- Found the file - Just fpath -> traceRn (ptext SLIT("...reading from") <+> text fpath) `thenRn_` - readIface mod_name fpath + Just mod | hi_boot_file, Just fpath <- moduleHiBootFile mod + -> readIface mod fpath + | not hi_boot_file, Just fpath <- moduleHiFile mod + -> readIface mod fpath -- Can't find it - Nothing -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr mod_name hi_boot_file search_path)) + other -> traceRn (ptext SLIT("...not found")) `thenRn_` + returnRn (Left (noIfaceErr finder mod_name hi_boot_file)) where trace_msg = sep [hsep [ptext SLIT("Reading"), @@ -1142,11 +1151,12 @@ findAndReadIface doc_str mod_name hi_boot_file @readIface@ tries just the one file. \begin{code} -readIface :: ModuleName -> String -> RnM d (Either Message ParsedIface) +readIface :: Module -> String -> RnM d (Either Message (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed readIface wanted_mod file_path - = ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> + = traceRn (ptext SLIT("...reading from") <+> text file_path) `thenRn_` + ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> case read_result of Right contents -> case parseIface contents @@ -1155,9 +1165,9 @@ readIface wanted_mod file_path glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of POk _ (PIface iface) -> - warnCheckRn (read_mod == wanted_mod) + warnCheckRn (moduleName wanted_mod == read_mod) (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` - returnRn (Right iface) + returnRn (Right (mod, iface)) where read_mod = moduleName (pi_mod iface) @@ -1213,10 +1223,10 @@ warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (pprModuleName mod_name) -hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn :: Module -> ModuleName -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") - , pprModuleName requested_mod + , ppr requested_mod , ptext SLIT("differs from name found in the interface file") , pprModuleName read_mod ] diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 306b7f3..10adbac 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -136,10 +136,10 @@ data SDown = SDown { -- We still need the unsullied global name env so that -- we can look up record field names - rn_fixenv :: FixityEnv -- Local fixities + rn_fixenv :: LocalFixityEnv -- Local fixities -- The global fixities are held in the -- rn_ifaces field. Why? See the comments - -- with RnIfaces.lookupFixity + -- with RnIfaces.lookupLocalFixity } data RnMode = SourceMode -- Renaming source code @@ -152,19 +152,14 @@ data RnMode = SourceMode -- Renaming source code \begin{code} -------------------------------- -type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes - -- These only get reported on lookup, - -- not on construction -type LocalRdrEnv = RdrNameEnv Name - --------------------------------- -type FixityEnv = NameEnv RenamedFixitySig +type LocalRdrEnv = RdrNameEnv Name +type LocalFixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate -- fixity declaration -lookupFixity :: FixityEnv -> Name -> Fixity -lookupFixity env name +lookupLocalFixity :: FixityEnv -> Name -> Fixity +lookupLocalFixity env name = case lookupNameEnv env name of Just (FixitySig _ fix _) -> fix Nothing -> defaultFixity @@ -255,27 +250,8 @@ data Ifaces = Ifaces { -- Subset of the previous field. } -type ImportedModuleInfo - = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface) - - -- Suppose the domain element is module 'A' - -- - -- The first Bool is True if A contains - -- 'orphan' rules or instance decls - - -- The second Bool is true if the interface file actually - -- read was an .hi-boot file - - -- Nothing => A's interface not yet read, but this module has - -- imported a module, B, that itself depends on A - -- - -- Just xx => A's interface has been read. The Module in - -- the Just has the correct Dll flag - - -- This set is used to decide whether to look for - -- A.hi or A.hi-boot when importing A.f. - -- Basically, we look for A.hi if A is in the map, and A.hi-boot - -- otherwise +type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface, IsLoaded) +type IsLoaded = True \end{code} @@ -290,32 +266,43 @@ initRn :: DynFlags -> Finder -> HomeSymbolTable -> PersistentCompilerState -> Module -> SrcLoc -> RnMG t - -> IO (t, (Bag WarnMsg, Bag ErrMsg)) + -> IO (t, PersistentCompilerState, (Bag WarnMsg, Bag ErrMsg)) initRn dflags finder hst pcs mod loc do_rn - = do uniqs <- mkSplitUniqSupply 'r' - names_var <- newIORef (uniqs, prsOrig prs) - errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef (initIfaces pcs) - let rn_down = RnDown { rn_mod = mod, - rn_loc = loc, - - rn_finder = finder, - rn_dflags = dflags, - rn_hst = hst, - - rn_ns = names_var, - rn_errs = errs_var, - rn_ifaces = iface_var, - } - - -- do the business - res <- do_rn rn_down () - - -- grab errors and return - (warns, errs) <- readIORef errs_var - - return (res, (warns, errs)) + = do + let prs = pcsPRS pcs + uniqs <- mkSplitUniqSupply 'r' + names_var <- newIORef (uniqs, prsOrig prs) + errs_var <- newIORef (emptyBag,emptyBag) + iface_var <- newIORef (initIfaces pcs) + let rn_down = RnDown { rn_mod = mod, + rn_loc = loc, + + rn_finder = finder, + rn_dflags = dflags, + rn_hst = hst, + + rn_ns = names_var, + rn_errs = errs_var, + rn_ifaces = iface_var, + } + + -- do the business + 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, + prsDecls = iDecls new_ifaces, + prsInsts = iInsts new_ifaces, + prsRules = iRules new_ifaces } + let new_pcs = pcs { pcsPST = iPST new_ifaces, + pcsPRS = new_prs } + + return (res, new_pcs, (warns, errs)) initIfaces :: PersistentCompilerState -> Ifaces @@ -545,12 +532,15 @@ getSrcLocRn down l_down \end{code} %================ -\subsubsection{The finder} +\subsubsection{The finder and home symbol table} %===================== \begin{code} getFinderRn :: RnM d Finder getFinderRn down l_down = return (rn_finder down) + +getHomeSymbolTableRn :: RnM d HomeSymbolTable +getHomeSymbolTableRn down l_down = return (rn_hst down) \end{code} %================ @@ -602,10 +592,6 @@ setModuleRn new_mod enclosed_thing rn_down l_down %===================== \begin{code} -getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) - = return (global_env, local_env) - getLocalNameEnv :: RnMS LocalRdrEnv getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) = return local_env @@ -618,7 +604,7 @@ setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a setLocalNameEnv local_env' m rn_down l_down = m rn_down (l_down {rn_lenv = local_env'}) -getFixityEnv :: RnMS FixityEnv +getFixityEnv :: RnMS LocalFixityEnv getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) = return fixity_env diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index eb83ac5..16fca3f 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -31,9 +31,7 @@ import Bag ( bagToList ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) import NameSet import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), - setNameProvenance, - nameOccName, getSrcLoc, pprProvenance, getNameProvenance, - nameEnvElts + setLocalNameSort, nameOccName, nameEnvElts ) import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual ) import OccName ( setOccNameSpace, dataName ) @@ -139,14 +137,6 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) returnRn Nothing else - -- RECORD BETTER PROVENANCES IN THE CACHE - -- The names in the envirnoment have better provenances (e.g. imported on line x) - -- than the names in the name cache. We update the latter now, so that we - -- we start renaming declarations we'll get the good names - -- The isQual is because the qualified name is always in scope - updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList gbl_env, - isQual rdr_name]) `thenRn_` - -- PROCESS EXPORT LISTS exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> @@ -223,27 +213,16 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> + let + mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) + (is_unqual name)) + in + qualifyImports imp_mod_name (not qual_only) -- Maybe want unqualified names as_mod hides - (improveAvails imp_mod iloc explicits - is_unqual filtered_avails) - - -improveAvails imp_mod iloc explicits is_unqual avails - -- We 'improve' the provenance by setting - -- (a) the import-reason field, so that the Name says how it came into scope - -- including whether it's explicitly imported - -- (b) the print-unqualified field - = map improve_avail avails - where - improve_avail (Avail n) = Avail (improve n) - improve_avail (AvailTC n ns) = AvailTC (improve n) (map improve ns) - - improve name = setNameProvenance name - (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - (is_unqual name)) - is_explicit name = name `elemNameSet` explicits + mk_provenance + filtered_avails \end{code} @@ -268,15 +247,16 @@ importsFromLocalDecls mod_name rec_exp_fn decls -- Build the environment qualifyImports mod_name - True -- Want unqualified names - Nothing -- no 'as M' - [] -- Hide nothing + True -- Want unqualified names + Nothing -- no 'as M' + [] -- Hide nothing + (\n -> LocalDef) -- Provenance is local avails - where mod = mkThisModule mod_name -getLocalDeclBinders :: Module -> (Name -> ExportFlag) +getLocalDeclBinders :: Module + -> (Name -> Bool) -- Is-exported predicate -> RdrNameHsDecl -> RnMG Avails getLocalDeclBinders mod rec_exp_fn (ValD binds) = mapRn do_one (bagToList (collectTopBinders binds)) @@ -291,9 +271,9 @@ getLocalDeclBinders mod rec_exp_fn decl Just avail -> returnRn [avail] newLocalName mod rec_exp_fn rdr_name loc - = check_unqual rdr_name loc `thenRn_` - newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name))) + = check_unqual rdr_name loc `thenRn_` + newTopBinder mod rdr_name loc `thenRn` \ name -> + returnRn (setLocalNameSort name (rec_exp_fn name)) where -- There should never be a qualified name in a binding position (except in instance decls) -- The parser doesn't check this because the same parser parses instance decls @@ -417,10 +397,11 @@ qualifyImports :: ModuleName -- Imported module -> Bool -- True <=> want unqualified import -> Maybe ModuleName -- Optional "as M" part -> [AvailInfo] -- What's to be hidden + -> (Name -> Provenance) -> Avails -- Whats imported and how -> RnMG (GlobalRdrEnv, ExportAvails) -qualifyImports this_mod unqual_imp as_mod hides avails +qualifyImports this_mod unqual_imp as_mod hides mk_provenance avails = -- Make the name environment. We're talking about a -- single module here, so there must be no name clashes. @@ -450,9 +431,10 @@ qualifyImports this_mod unqual_imp as_mod hides avails | unqual_imp = env2 | otherwise = env1 where - env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name - env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name + env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) (name,prov) + env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov) occ = nameOccName name + prov = mk_provenance name del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where @@ -605,7 +587,7 @@ exportsFromAvail this_mod (Just export_items) where rdr_name = ieName ie maybe_in_scope = lookupFM global_name_env rdr_name - Just (name:dup_names) = maybe_in_scope + Just ((name,_):dup_names) = maybe_in_scope maybe_avail = lookupUFM entity_avail_env name Just avail = maybe_avail maybe_export_avail = filterAvail ie avail @@ -676,13 +658,10 @@ exportClashErr occ_name ie1 ie2 dupDeclErr (n:ns) = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), - nest 4 (vcat (map pp sorted_ns))] + nest 4 (vcat (map ppr sorted_locs))] where - sorted_ns = sortLt occ'ed_before (n:ns) - - occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b) - - pp n = pprProvenance (getNameProvenance n) + sorted_locs = sortLt occ'ed_before (map nameSrcLoc (n:ns)) + occ'ed_before a b = LT == compare a b dupExportWarn occ_name ie1 ie2 = hsep [quotes (ppr occ_name), diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 29f9a6a..866b8ff 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -32,7 +32,7 @@ import Id ( Id, idType, isId, idName, ) import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) -import Name ( isLocalName, setNameUnique ) +import Name ( setNameUnique ) import Demand ( Demand, isStrict, wwLazy, wwLazy ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType, diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index e106cba..5282dea 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -265,7 +265,7 @@ newDFunName mod clas (ty:_) loc tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (mkGlobalName uniq mod (mkDFunOcc dfun_string inst_uniq) - (LocalDef loc Exported)) + loc) where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) @@ -275,7 +275,7 @@ newDefaultMethodName op_name loc = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (mkGlobalName uniq (nameModule op_name) (mkDefaultMethodOcc (getOccName op_name)) - (LocalDef loc Exported)) + loc) \end{code} diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 6bf53ae..f9643dc 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -27,9 +27,7 @@ import Var ( TyVar, UVar ) import VarEnv import VarSet -import Name ( Name, Provenance(..), ExportFlag(..), - mkGlobalName, mkKindOccFS, tcName, - ) +import Name ( Name, mkGlobalName, mkKindOccFS, tcName ) import OccName ( mkOccFS, tcName ) import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, @@ -37,7 +35,7 @@ import TyCon ( TyCon, KindCon, import Class ( Class ) -- others -import SrcLoc ( mkBuiltinSrcLoc ) +import SrcLoc ( builtinSrcLoc ) import PrelNames ( pREL_GHC, kindConKey, boxityConKey, boxedConKey, unboxedConKey, typeConKey, anyBoxConKey, funTyConName ) @@ -224,8 +222,7 @@ in two situations: \begin{code} -mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) - (LocalDef mkBuiltinSrcLoc NotExported) +mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) builtinSrcLoc -- mk_kind_name is a bit of a hack -- The LocalDef means that we print the name without -- a qualifier, which is what we want for these kinds. -- 1.7.10.4