From d2cca44eae15bbbd3b86889448e796bc785dfa52 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 23 Oct 2000 16:39:12 +0000 Subject: [PATCH] [project @ 2000-10-23 16:39:11 by simonpj] More renamer stuff --- ghc/compiler/basicTypes/Module.lhs | 5 +- ghc/compiler/basicTypes/VarEnv.lhs | 4 +- ghc/compiler/main/HscMain.lhs | 10 +- ghc/compiler/main/HscTypes.lhs | 30 ++- ghc/compiler/prelude/PrelRules.lhs | 3 +- ghc/compiler/rename/ParseIface.y | 6 +- ghc/compiler/rename/Rename.lhs | 373 ++++++++++++++++++------------------ ghc/compiler/rename/RnEnv.lhs | 24 ++- ghc/compiler/rename/RnIfaces.lhs | 107 +++++------ ghc/compiler/rename/RnMonad.lhs | 15 +- ghc/compiler/rename/RnNames.lhs | 16 +- 11 files changed, 299 insertions(+), 294 deletions(-) diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 426fdf4..e689c97 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -56,7 +56,8 @@ module Module , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv - , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, lookupModuleEnvByName + , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv + , lookupModuleEnvByName, extendModuleEnv_C ) where @@ -266,6 +267,7 @@ emptyModuleEnv :: ModuleEnv a mkModuleEnv :: [(Module, a)] -> ModuleEnv a unitModuleEnv :: Module -> a -> ModuleEnv a extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a @@ -284,6 +286,7 @@ foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b elemModuleEnv = elemUFM extendModuleEnv = addToUFM +extendModuleEnv_C = addToUFM_C extendModuleEnvList = addListToUFM plusModuleEnv_C = plusUFM_C delModuleEnvList = delListFromUFM diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index 03eb4e1..646d5fa 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -8,7 +8,7 @@ module VarEnv ( VarEnv, IdEnv, TyVarEnv, emptyVarEnv, unitVarEnv, mkVarEnv, elemVarEnv, rngVarEnv, - extendVarEnv, extendVarEnvList, + extendVarEnv, extendVarEnv_C, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, @@ -127,6 +127,7 @@ mkVarEnv :: [(Var, a)] -> VarEnv a zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a @@ -148,6 +149,7 @@ foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b \begin{code} elemVarEnv = elemUFM extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C delVarEnvList = delListFromUFM diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 5f41edb..63dabf0 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -21,6 +21,7 @@ import SrcLoc ( mkSrcLoc ) import Rename ( renameModule ) import PrelInfo ( wiredInThings ) +import PrelRules ( builtinRules ) import MkIface ( writeIface ) import TcModule ( TcResults(..), typecheckModule ) import Desugar ( deSugar ) @@ -254,7 +255,7 @@ initPersistentCompilerState :: PersistentCompilerState initPersistentCompilerState = PCS { pcs_PST = initPackageDetails, pcs_insts = emptyInstEnv, - pcs_rules = emptyRuleEnv, + pcs_rules = initRules, pcs_PRS = initPersistentRenamerState } initPackageDetails :: PackageSymbolTable @@ -273,4 +274,11 @@ initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings) where grab names = foldl add emptyFM names add env name = addToFM env (moduleName (nameModule name), nameOccName name) name + + +initRules :: RuleEnv +initRules = foldl add emptyVarEnv builtinRules + where + add env (name,rule) = extendNameEnv_C add1 env name [rule] + add1 rules _ = rule : rules \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 09a42c9..84b129b 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -21,7 +21,7 @@ module HscTypes ( WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, DeprecationEnv, GatedDecl, + IfaceInsts, IfaceRules, Deprecations(..), GatedDecl, OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -113,13 +113,16 @@ data ModIface mi_module :: Module, -- Complete with package info mi_version :: VersionInfo, -- Module version number mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + mi_usages :: [ImportVersion Name], -- Usages - mi_exports :: Avails, -- What it exports + mi_exports :: Avails, -- What it exports; kept sorted by (mod,occ), + -- to make version comparisons easier + mi_globals :: GlobalRdrEnv, -- Its top level environment mi_fixities :: NameEnv Fixity, -- Fixities - mi_deprecs :: NameEnv DeprecTxt, -- Deprecations + mi_deprecs :: Deprecations, -- Deprecations mi_decls :: [RenamedHsDecl] -- types, classes -- inst decls, rules, iface sigs @@ -149,7 +152,7 @@ emptyModIface mod = ModIface { mi_module = mod, mi_exports = [], mi_globals = emptyRdrEnv, - mi_deprecs = emptyNameEnv, + mi_deprecs = NoDeprecs } \end{code} @@ -258,13 +261,16 @@ data VersionInfo -- the parent class/tycon changes } -type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation +data Deprecations = NoDeprecs + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome (NameEnv DeprecTxt) -- Some things deprecated + -- Just "big" names type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class type DFunId = Id -type RuleEnv = IdEnv [CoreRule] +type RuleEnv = NameEnv [CoreRule] emptyRuleEnv = emptyVarEnv \end{code} @@ -468,16 +474,6 @@ instance Ord ImportReason where = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) -{- -Moved here from Name. -pp_prov (LocalDef _ Exported) = char 'x' -pp_prov (LocalDef _ NotExported) = char 'l' -pp_prov (NonLocalDef ImplicitImport _) = char 'j' -pp_prov (NonLocalDef (UserImport _ _ True ) _) = char 'I' -- Imported by name -pp_prov (NonLocalDef (UserImport _ _ False) _) = char 'i' -- Imported by .. -pp_prov SystemProv = char 's' --} - data ImportReason = UserImport Module SrcLoc Bool -- Imported from module M on line L -- Note the M may well not be the defining module @@ -510,7 +506,7 @@ hasBetterProv (NonLocalDef (UserImport _ _ _ ) _) (NonLocalDef ImplicitImport hasBetterProv _ _ = False pprNameProvenance :: Name -> Provenance -> SDoc -pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) pprNameProvenance name (NonLocalDef why _) = sep [ppr_reason why, nest 2 (parens (ppr_defn (nameSrcLoc name)))] diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index adee169..dff38e6 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -429,7 +429,8 @@ builtinRules ] --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n +-- The rule is this: +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n match_append_lit_str [Type ty1, Lit (MachStr s1), diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index b9cfc89..70cbf6b 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -225,16 +225,16 @@ iface : '__interface' package mod_name pi_mod = mkModule $3 $2, -- Module itself pi_vers = $4, -- Module version pi_orphan = $6, - pi_exports = $9, -- Exports + pi_exports = (fst $5, $9), -- Exports pi_usages = $10, -- Usages - pi_fixity = (fst $5,$11), -- Fixies + pi_fixity = $11, -- Fixies pi_insts = $12, -- Local instances pi_decls = $13, -- Decls pi_rules = (snd $5,fst $14), -- Rules pi_deprecs = snd $14 -- Deprecations } } --- Versions for fixities and rules (optional) +-- Versions for exports and rules (optional) sub_versions :: { (Version,Version) } : '[' version version ']' { ($2,$3) } | {- empty -} { (initialVersion, initialVersion) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c1fbead..3aaffac 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -19,41 +19,37 @@ import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, +import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo, getInterfaceExports, getImportedRules, getSlurped, removeContext, - loadBuiltinRules, getDeferredDecls, ImportDeclResult(..) + ImportDeclResult(..), findAndReadIface ) import RnEnv ( availName, availsToNameSet, - emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, + emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, lookupOrigNames, unknownNameErr, FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, mkModuleInThisPackage + moduleNameUserString, moduleName, mkModuleInThisPackage, + lookupModuleEnv ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, - nameOccName, nameUnique, nameModule, --- maybeUserImportedFrom, --- isUserImportedExplicitlyName, isUserImportedName, --- maybeWiredInTyConName, maybeWiredInIdName, + nameOccName, nameUnique, nameModule, isUserExportedName, toRdrName, - nameEnvElts, extendNameEnv + mkNameEnv, nameEnvElts, extendNameEnv ) import OccName ( occNameFlavour, isValOcc ) import Id ( idType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelRules ( builtinRules ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) -import PrelInfo ( fractionalClassKeys, derivingOccurrences, - maybeWiredInTyConName, maybeWiredInIdName ) +import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) import BasicTypes ( Version, initialVersion ) @@ -67,38 +63,30 @@ import SrcLoc ( noSrcLoc ) import Maybes ( maybeToBool, expectJust ) import Outputable import IO ( openFile, IOMode(..) ) -import HscTypes ( Finder, PersistentCompilerState, HomeSymbolTable, GlobalRdrEnv, - AvailEnv, Avails, GenAvailInfo(..), AvailInfo, - Provenance(..), ImportReason(..) ) - --- HACKS: -maybeUserImportedFrom = panic "maybeUserImportedFrom" -isUserImportedExplicitlyName = panic "isUserImportedExplicitlyName" -isUserImportedName = panic "isUserImportedName" -iDeprecs = panic "iDeprecs" -type FixityEnv = LocalFixityEnv +import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, + ModIface(..), TyThing(..), + GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, + Provenance(..), pprNameProvenance, ImportReason(..) ) +import List ( partition, nub ) \end{code} \begin{code} -type RenameResult = ( PersistentCompilerState - , ModIface - ) - renameModule :: DynFlags -> Finder - -> PersistentCompilerState -> HomeSymbolTable - -> RdrNameHsModule + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module -> RdrNameHsModule -> IO (PersistentCompilerState, Maybe ModIface) -- The mi_decls in the ModIface include -- ones imported from packages too -renameModule dflags finder old_pcs hst - this_mod@(HsModule mod_name vers exports imports local_decls _ loc) +renameModule dflags finder hit hst old_pcs this_module + this_mod@(HsModule _ _ _ _ _ _ loc) = -- Initialise the renamer monad do { ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) - <- initRn dflags finder old_pcs hst loc (rename this_mod) ; + <- initRn dflags finder hit hst old_pcs this_module loc (rename this_module this_mod) ; -- Check for warnings printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ; @@ -115,8 +103,8 @@ renameModule dflags finder old_pcs hst \end{code} \begin{code} -rename :: RdrNameHsModule -> RnMG (Maybe ModIface, IO ()) -rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe ModIface, IO ()) +rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -126,7 +114,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l rnDump [] [] `thenRn` \ dump_action -> returnRn (Nothing, dump_action) ; - Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) -> + Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> -- DEAL WITH DEPRECATIONS rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs -> @@ -155,7 +143,6 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l -- when compiling the prelude, locally-defined (), Bool, etc -- override the implicit ones. in - loadBuiltinRules builtinRules `thenRn_` slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND @@ -167,15 +154,14 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l else -- GENERATE THE VERSION/USAGE INFO - mkImportExportInfo mod_name export_avails imports `thenRn` \ (my_exports, my_usages) -> + mkImportInfo mod_name imports `thenRn` \ my_usages -> -- RETURN THE RENAMED MODULE getNameSupplyRn `thenRn` \ name_supply -> getIfacesRn `thenRn` \ ifaces -> let - direct_import_mods :: [Module] - direct_import_mods = [m | (_, _, Just (m, _, _, _, imp, _)) - <- eltsFM (iImpModInfo ifaces), user_import imp] + direct_import_mods :: [ModuleName] + direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] -- *don't* just pick the forward edges. It's entirely possible -- that a module is only reachable via back edges. @@ -183,8 +169,6 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l user_import ImportByUserSource = True user_import _ = False - this_module = mkModuleInThisPackage mod_name - -- Export only those fixities that are for names that are -- (a) defined in this module -- (b) exported @@ -194,14 +178,18 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l isUserExportedName name ] - mod_iface = ModIface { mi_module = this_module - mi_version = panic "mi_version: not filled in yet", - mi_orphan = any isOrphanDecl rn_local_decls, - mi_exports = my_exports, - mi_usages = my_usages, - mi_fixity = exported_fixities) - mi_deprecs = my_deprecs - mi_decls = rn_local_decls ++ rn_imp_decls + + -- Sort the exports to make them easier to compare for versions + my_exports = sortAvails export_avails + + mod_iface = ModIface { mi_module = this_module, + mi_version = panic "mi_version: not filled in yet", + mi_orphan = any isOrphanDecl rn_local_decls, + mi_exports = my_exports, + mi_usages = my_usages, + mi_fixities = exported_fixities, + mi_deprecs = my_deprecs, + mi_decls = rn_local_decls ++ rn_imp_decls } in @@ -464,6 +452,10 @@ Whether all this is worth it is moot. \begin{code} slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] +slurpDeferredDecls decls = returnRn decls + +{- OMIT FOR NOW +slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] slurpDeferredDecls decls = getDeferredDecls `thenRn` \ def_decls -> rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> @@ -476,6 +468,7 @@ stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2)) -- Nuke the context and constructors -- But retain the *number* of constructors! -- Also the tvs will have kinds on them. +-} \end{code} @@ -566,17 +559,16 @@ rather than a declaration. \begin{code} getWiredInGates :: Name -> FreeVars getWiredInGates name -- No classes are wired in - | is_id = getWiredInGates_s (namesOfType (idType the_id)) - | isSynTyCon the_tycon = getWiredInGates_s - (delListFromNameSet (namesOfType ty) (map getName tyvars)) - | otherwise = unitFV name - where - maybe_wired_in_id = maybeWiredInIdName name - is_id = maybeToBool maybe_wired_in_id - maybe_wired_in_tycon = maybeWiredInTyConName name - Just the_id = maybe_wired_in_id - Just the_tycon = maybe_wired_in_tycon - (tyvars,ty) = getSynTyConDefn the_tycon + = case lookupNameEnv wiredInThingEnv name of + Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id)) + + Just (ATyCon tc) + | isSynTyCon tc + -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) + where + (tyvars,ty) = getSynTyConDefn tc + + other -> unitFV name getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) \end{code} @@ -594,7 +586,7 @@ getInstDeclGates other = emptyFVs %********************************************************* \begin{code} -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv +fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv fixitiesFromLocalDecls gbl_env decls = doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused -> foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env -> @@ -602,7 +594,7 @@ fixitiesFromLocalDecls gbl_env decls `thenRn_` returnRn env where - getFixities :: Bool -> FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv + getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv getFixities warn_uu acc (FixD fix) = fix_decl warn_uu acc fix @@ -671,7 +663,7 @@ rnDeprecs gbl_env mod_deprec decls %********************************************************* \begin{code} -reportUnusedNames :: ModuleName -> [Module] +reportUnusedNames :: ModuleName -> [ModuleName] -> GlobalRdrEnv -> AvailEnv -> Avails -> NameSet -> [RenamedHsDecl] -> RnMG () @@ -679,127 +671,136 @@ reportUnusedNames mod_name direct_import_mods gbl_env avail_env export_avails mentioned_names imported_decls - = let - used_names = mentioned_names `unionNameSets` availsToNameSet export_avails - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names = used_names `unionNameSets` - mkNameSet [ availName parent_avail - | sub_name <- nameSetToList used_names - , isValOcc (getOccName sub_name) - - -- Usually, every used name will appear in avail_env, but there - -- is one time when it doesn't: tuples and other built in syntax. When you - -- write (a,b) that gives rise to a *use* of "(,)", so that the - -- instances will get pulled in, but the tycon "(,)" isn't actually - -- in scope. Hence the isValOcc filter. - -- - -- Also, (-x) gives rise to an implicit use of 'negate'; similarly, - -- 3.5 gives rise to an implcit use of :% - -- hence the isUserImportedName filter on the warning - - , let parent_avail - = case lookupNameEnv avail_env sub_name of - Just avail -> avail - Nothing -> WARN( isUserImportedName sub_name, - text "reportUnusedName: not in avail_env" <+> - ppr sub_name ) - Avail sub_name - - , case parent_avail of { AvailTC _ _ -> True; other -> False } - ] - - 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 :: [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, - not (isLocallyDefined n), - Just txt <- [lookupNameEnv deprec_env n] ] - - -- inst_mods are directly-imported modules that - -- contain instance decl(s) that the renamer decided to suck in - -- It's not necessarily redundant to import such modules. - -- - -- NOTE: Consider - -- module This - -- import M () - -- - -- The import M() is not *necessarily* redundant, even if - -- we suck in no instance decls from M (e.g. it contains - -- no instance decls, or This contains no code). It may be - -- that we import M solely to ensure that M's orphan instance - -- decls (or those in its imports) are visible to people who - -- import This. Sigh. - -- There's really no good way to detect this, so the error message - -- in RnEnv.warnUnusedModules is weakened instead - inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls, - let m = nameModule dfun, - m `elem` direct_import_mods - ] - - minimal_imports :: FiniteMap Module AvailEnv - minimal_imports0 = emptyFM - minimal_imports1 = foldNameSet add_name minimal_imports0 really_used_names - minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods - - add_name n acc = case maybeUserImportedFrom n of - Nothing -> acc - Just m -> addToFM_C plusAvailEnv acc m - (unitAvailEnv (mk_avail n)) - add_inst_mod m acc - | m `elemFM` acc = acc -- We import something already - | otherwise = addToFM acc m emptyAvailEnv - -- Add an empty collection of imports for a module - -- from which we have sucked only instance decls - - mk_avail n = case lookupNameEnv avail_env n of - Just (AvailTC m _) | n==m -> AvailTC n [n] - | otherwise -> AvailTC m [n,m] - Just avail -> Avail n - Nothing -> pprPanic "mk_avail" (ppr n) - - -- unused_imp_mods are the directly-imported modules - -- that are not mentioned in minimal_imports - unused_imp_mods = [m | m <- direct_import_mods, - not (maybeToBool (lookupFM minimal_imports m)), - moduleName m /= pRELUDE_Name] - - module_unused :: Module -> Bool - module_unused mod = mod `elem` unused_imp_mods - - in - warnUnusedModules unused_imp_mods `thenRn_` + = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` printMinimalImports mod_name minimal_imports `thenRn_` - getIfacesRn `thenRn` \ ifaces -> - doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> - (if warn_drs - then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces)) - else returnRn ()) + warnDeprecations really_used_names `thenRn_` + returnRn () + + where + used_names = mentioned_names `unionNameSets` availsToNameSet export_avails + + -- Now, a use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + really_used_names = used_names `unionNameSets` + mkNameSet [ parent_name + | sub_name <- nameSetToList used_names + + -- Usually, every used name will appear in avail_env, but there + -- is one time when it doesn't: tuples and other built in syntax. When you + -- write (a,b) that gives rise to a *use* of "(,)", so that the + -- instances will get pulled in, but the tycon "(,)" isn't actually + -- in scope. Also, (-x) gives rise to an implicit use of 'negate'; + -- similarly, 3.5 gives rise to an implcit use of :% + -- Hence the silent 'False' in all other cases + + , Just parent_name <- [case lookupNameEnv avail_env sub_name of + Just (AvailTC n _) -> Just n + other -> Nothing] + ] + + defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)] + defined_names = concat (rdrEnvElts gbl_env) + (defined_and_used, defined_but_not_used) = partition used defined_names + used (name,_) = not (name `elemNameSet` really_used_names) + + -- Filter out the ones only defined implicitly + bad_locals :: [Name] + bad_locals = [n | (n,LocalDef) <- defined_but_not_used] + + bad_imp_names :: [(Name,Provenance)] + bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True) _)) <- defined_but_not_used, + not (module_unused mod)] + + -- inst_mods are directly-imported modules that + -- contain instance decl(s) that the renamer decided to suck in + -- It's not necessarily redundant to import such modules. + -- + -- NOTE: Consider + -- module This + -- import M () + -- + -- The import M() is not *necessarily* redundant, even if + -- we suck in no instance decls from M (e.g. it contains + -- no instance decls, or This contains no code). It may be + -- that we import M solely to ensure that M's orphan instance + -- decls (or those in its imports) are visible to people who + -- import This. Sigh. + -- There's really no good way to detect this, so the error message + -- in RnEnv.warnUnusedModules is weakened instead + inst_mods :: [ModuleName] + inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls, + let m = moduleName (nameModule dfun), + m `elem` direct_import_mods + ] + + -- To figure out the minimal set of imports, start with the things + -- that are in scope (i.e. in gbl_env). Then just combine them + -- into a bunch of avails, so they are properly grouped + minimal_imports :: FiniteMap ModuleName AvailEnv + minimal_imports0 = emptyFM + minimal_imports1 = foldr add_name minimal_imports0 defined_and_used + minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods + + add_name (n,NonLocalDef (UserImport m _ _) _) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n)) + (unitAvailEnv (mk_avail n)) + add_name (n,other_prov) acc = acc + + mk_avail n = case lookupNameEnv avail_env n of + Just (AvailTC m _) | n==m -> AvailTC n [n] + | otherwise -> AvailTC m [n,m] + Just avail -> Avail n + Nothing -> pprPanic "mk_avail" (ppr n) + + add_inst_mod m acc + | m `elemFM` acc = acc -- We import something already + | otherwise = addToFM acc m emptyAvailEnv + -- Add an empty collection of imports for a module + -- from which we have sucked only instance decls + + -- unused_imp_mods are the directly-imported modules + -- that are not mentioned in minimal_imports + unused_imp_mods = [m | m <- direct_import_mods, + not (maybeToBool (lookupFM minimal_imports m)), + m /= pRELUDE_Name] + + module_unused :: ModuleName -> Bool + module_unused mod = mod `elem` unused_imp_mods + + +warnDeprecations used_names + = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> + if not warn_drs then returnRn () else + + getIfacesRn `thenRn` \ ifaces -> + getHomeIfaceTableRn `thenRn` \ hit -> + let + pit = iPIT ifaces + deprecs = [ (n,txt) + | n <- nameSetToList used_names, + Just txt <- [lookup_deprec hit pit n] ] + in + mapRn_ warnDeprec deprecs + + where + lookup_deprec hit pit n + = case lookupModuleEnv hit mod of + Just iface -> lookup_iface iface n + Nothing -> case lookupModuleEnv pit mod of + Just iface -> lookup_iface iface n + Nothing -> pprPanic "warnDeprecations:" (ppr n) + where + mod = nameModule n + + lookup_iface iface n = lookupNameEnv (mi_deprecs iface) n -- ToDo: deal with original imports with 'qualified' and 'as M' clauses printMinimalImports mod_name imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> - printMinimalImports_wrk dump_minimal mod_name imps + if not dump_minimal then returnRn () else -printMinimalImports_wrk dump_minimal mod_name imps - | not dump_minimal - = returnRn () - | otherwise - = mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> + mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> ioToRnM (do { h <- openFile filename WriteMode ; printForUser h (vcat (map ppr_mod_ie mod_ies)) }) `thenRn_` @@ -814,7 +815,7 @@ printMinimalImports_wrk dump_minimal mod_name imps parens (fsep (punctuate comma (map ppr ies))) to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies -> - returnRn (moduleName mod, ies) + returnRn (mod, ies) to_ie :: AvailInfo -> RnMG (IE Name) to_ie (Avail n) = returnRn (IEVar n) @@ -856,9 +857,9 @@ getRnStats :: [RenamedHsDecl] -> RnMG SDoc getRnStats imported_decls = getIfacesRn `thenRn` \ ifaces -> let - n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] + n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] - decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), -- Data, newtype, and class decls are in the decls_fm -- under multiple names; the tycon/class, and each -- constructor/class op too. @@ -935,7 +936,14 @@ dupFixityDecl rdr_name loc1 loc2 \end{code} +%******************************************************** +%* * +\subsection{Checking usage information} +%* * +%******************************************************** + \begin{code} +{- checkEarlyExit mod_name = traceRn (text "Considering whether compilation is required...") `thenRn_` @@ -964,12 +972,6 @@ checkEarlyExit mod_name doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name] \end{code} -%******************************************************** -%* * -\subsection{Checking usage information} -%* * -%******************************************************** - \begin{code} upToDate = True outOfDate = False @@ -1066,6 +1068,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate +-} \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index e9efa34..d4ff303 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -16,7 +16,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ImportReason(..), GlobalRdrEnv, AvailEnv, - AvailInfo, GenAvailInfo(..), RdrAvailInfo ) + AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo ) import RnMonad import Name ( Name, NamedThing(..), getSrcLoc, @@ -582,16 +582,19 @@ availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns +------------------------------------- addSysAvails :: AvailInfo -> [Name] -> AvailInfo addSysAvails avail [] = avail addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) +------------------------------------- rdrAvailInfo :: AvailInfo -> RdrAvailInfo -- Used when building the avails we are going to put in an interface file -- We sort the components to reduce needless wobbling of interfaces rdrAvailInfo (Avail n) = Avail (nameOccName n) rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns)) +------------------------------------- filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; @@ -627,6 +630,21 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing +------------------------------------- +sortAvails :: Avails -> Avails +sortAvails avails = sortLt lt avails + where + a1 `lt` a2 = mod1 < mod2 || + (mod1 == mod2 && occ1 < occ2) + where + name1 = availName a1 + name2 = availName a2 + mod1 = nameModule name1 + mod2 = nameModule name2 + occ1 = nameOccName name1 + occ2 = nameOccName name2 + +------------------------------------- pprAvail :: AvailInfo -> SDoc pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of [] -> empty @@ -678,7 +696,7 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [Module] -> RnM d () +warnUnusedModules :: [ModuleName] -> RnM d () warnUnusedModules mods = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> if warn then mapRn_ (addWarnRn . unused_mod) mods @@ -687,7 +705,7 @@ warnUnusedModules mods unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", parens (ptext SLIT("except perhaps to re-export instances visible in") <+> - quotes (ppr (moduleName m)))] + quotes (ppr m))] warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 05aa9c2..62993fd 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -11,8 +11,8 @@ module RnIfaces getInterfaceExports, getImportedInstDecls, getImportedRules, lookupFixityRn, loadHomeInterface, - importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules, - mkImportExportInfo, getSlurped, + importDecl, ImportDeclResult(..), recordLocalSlurps, + mkImportInfo, getSlurped, getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else @@ -47,8 +47,8 @@ import Name ( Name {-instance NamedThing-}, nameOccName, import Module ( Module, ModuleEnv, moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), - extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName, - plusModuleEnv_C, lookupWithDefaultModuleEnv + emptyModuleEnv, extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName, + extendModuleEnv_C, lookupWithDefaultModuleEnv ) import RdrName ( RdrName, rdrNameOcc ) import NameSet @@ -171,13 +171,13 @@ tryLoadInterface doc_str mod_name from 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) emptyNameEnv (pi_deprecs iface) `thenRn` \ deprec_env -> + loadFixDecls mod_name (pi_fixity iface) `thenRn` \ fix_env -> + loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - loadExports (pi_exports iface) `thenRn` \ avails -> + loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> let version = VersionInfo { vers_module = pi_vers iface, - fixVers = fix_vers, + vers_exports = export_vers, vers_rules = rule_vers, vers_decls = decls_vers } @@ -225,7 +225,7 @@ 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 :: [(ModuleName, (WhetherHasOrphans, IsBootInterface, IsLoaded))] filtered_new_deps | isModuleInThisPackage mod = [ (imp_mod, (has_orphans, is_boot, False)) @@ -247,11 +247,11 @@ addModDeps mod new_deps mod_deps -- Loading the export list ----------------------------------------------------- -loadExports :: [ExportItem] -> RnM d Avails -loadExports items +loadExports :: (Version, [ExportItem]) -> RnM d (Version, Avails) +loadExports (vers, items) = getModuleRn `thenRn` \ this_mod -> mapRn (loadExport this_mod) items `thenRn` \ avails_s -> - returnRn (concat avails_s) + returnRn (vers, concat avails_s) loadExport :: Module -> ExportItem -> RnM d [AvailInfo] @@ -361,9 +361,9 @@ loadDecl mod (version_map, decls_map) (version, decl) -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod_name (version, decls) +loadFixDecls mod_name decls = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> - returnRn (version, mkNameEnv to_add) + returnRn (mkNameEnv to_add) loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> @@ -431,31 +431,20 @@ loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) = lookupOrigName var `thenRn` \ var_name -> returnRn (unitNameSet var_name, (mod, RuleD decl)) -loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG () -loadBuiltinRules builtin_rules - = getIfacesRn `thenRn` \ ifaces -> - mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls -> - setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls }) - -loadBuiltinRule (var, rule) - = lookupOrigName var `thenRn` \ var_name -> - returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule))) - ----------------------------------------------------- -- Loading Deprecations ----------------------------------------------------- -loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv -loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _) - = traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_` - -- SUP: TEMPORARY HACK, ignoring module deprecations for now - returnRn deprec_env - -loadDeprec mod deprec_env (Deprecation ie txt _) - = setModuleRn mod $ - mapRn lookupOrigName (ieNames ie) `thenRn` \ names -> - traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_` +loadDeprecs :: Module -> [RdrNameDeprecation] -> RnM d Deprecations +loadDeprecs m [] = returnRn NoDeprecs +loadDeprecs m [Deprecation (IEModuleContents _) txt _] = returnRn (DeprecAll txt) +loadDeprecs m deprecs = setModuleRn m $ + foldlRn loadDeprec emptyNameEnv deprecs `thenRn` \ env -> + returnRn (DeprecSome env) +loadDeprec deprec_env (Deprecation ie txt _) + = mapRn lookupOrigName (ieNames ie) `thenRn` \ names -> + traceRn (text "Loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_` returnRn (extendNameEnvList deprec_env (zip names (repeat txt))) \end{code} @@ -782,33 +771,32 @@ imports A. This line says that A imports B, but uses nothing in it. So we'll get an early bale-out when compiling A if B's version changes. \begin{code} -mkImportExportInfo :: ModuleName -- Name of this module - -> Avails -- Info about exports - -> [ImportDecl n] -- The import decls - -> RnMG ([ExportItem], -- Export info for iface file; sorted - [ImportVersion Name]) -- Import info for iface file; sorted - -- Both results are sorted into canonical order to - -- reduce needless wobbling of interface files - -mkImportExportInfo this_mod export_avails exports +mkImportInfo :: ModuleName -- Name of this module + -> [ImportDecl n] -- The import decls + -> RnMG [ImportVersion Name] + +mkImportInfo this_mod imports = getIfacesRn `thenRn` \ ifaces -> + getHomeIfaceTableRn `thenRn` \ hit -> let import_all_mods :: [ModuleName] -- Modules where we imported all the names -- (apart from hiding some, perhaps) - import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports ] + import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports, + import_all imp_list ] import_all (Just (False, _)) = False -- Imports are specified explicitly import_all other = True -- Everything is imported mod_map = iImpModInfo ifaces imp_names = iVSlurp ifaces + pit = iPIT ifaces -- mv_map groups together all the things imported from a particular module. mv_map :: ModuleEnv [Name] - mv_map = foldr add_mv emptyFM imp_names + mv_map = foldr add_mv emptyModuleEnv imp_names - add_mv (name, version) mv_map = addItem mv_map (nameModule name) name + add_mv name mv_map = addItem mv_map (nameModule name) name -- Build the result list by adding info for each module. -- For (a) a library module, we don't record it at all unless it contains orphans @@ -847,10 +835,10 @@ mkImportExportInfo this_mod export_avails exports = so_far | is_lib_module -- Record the module version only - = go_for_it (Everything vers_module) + = go_for_it (Everything module_vers) | otherwise - = go_for_it (mk_whats_imported mod vers_module) + = go_for_it whats_imported where go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far @@ -859,12 +847,14 @@ mkImportExportInfo this_mod export_avails exports is_lib_module = not (isModuleInThisPackage mod) version_info = mi_version mod_iface version_env = vers_decls version_info + module_vers = vers_module version_info - whats_imported = Specifically mod_vers export_vers import_items + whats_imported = Specifically module_vers + export_vers import_items (vers_rules version_info) import_items = [(n,v) | n <- lookupWithDefaultModuleEnv mv_map [] mod, - let v = lookupNameEnv version_env `orElse` + let v = lookupNameEnv version_env n `orElse` pprPanic "mk_whats_imported" (ppr n) ] export_vers | moduleName mod `elem` import_all_mods @@ -873,22 +863,13 @@ mkImportExportInfo this_mod export_avails exports = Nothing import_info = foldFM mk_imp_info [] mod_map - - -- Sort exports into groups by module - export_fm :: FiniteMap Module [RdrAvailInfo] - export_fm = foldr insert emptyFM export_avails - - insert avail efm = addItem efm (nameModule (availName avail)) - avail - - export_info = fmToList export_fm in traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_` - returnRn (export_info, import_info) + returnRn import_info addItem :: ModuleEnv [a] -> Module -> a -> ModuleEnv [a] -addItem fm mod x = plusModuleEnv_C add_item fm mod [x] +addItem fm mod x = extendModuleEnv_C add_item fm mod [x] where add_item xs _ = x:xs \end{code} @@ -1044,7 +1025,7 @@ findAndReadIface doc_str mod_name hi_boot_file ioToRnM (finder mod_name) `thenRn` \ maybe_found -> case maybe_found of - Just (mod,locn) + Right (Just (mod,locn)) | hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot") | otherwise -> readIface mod (hi_file locn) @@ -1129,7 +1110,7 @@ warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (ppr mod_name) -hiModuleNameMismatchWarn :: Module -> ModuleName -> Message +hiModuleNameMismatchWarn :: Module -> Module -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") , ppr (moduleName requested_mod) diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 4c0c519..1b3bcfc 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -201,11 +201,10 @@ data ParsedIface pi_vers :: Version, -- Module version number pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages - pi_exports :: [ExportItem], -- Exports + pi_exports :: (Version, [ExportItem]), -- Exports pi_insts :: [RdrNameInstDecl], -- Local instance declarations pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions - pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, - -- with their version + pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations, pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version pi_deprecs :: [RdrNameDeprecation] -- Deprecations } @@ -290,7 +289,7 @@ initRn :: DynFlags -> Module -> SrcLoc -> RnMG t - -> IO (t, PersistentCompilerState, (Bag WarnMsg, Bag ErrMsg)) + -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState) initRn dflags finder hit hst pcs mod loc do_rn = do @@ -330,7 +329,7 @@ initRn dflags finder hit hst pcs mod loc do_rn let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } - return (res, new_pcs, (warns, errs)) + return (res, (warns, errs), new_pcs) is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool -- Returns True iff the name is in either symbol table @@ -402,8 +401,8 @@ renameSourceCode dflags mod prs m rn_loc = generatedSrcLoc, rn_ns = names_var, rn_errs = errs_var, rn_mod = mod, - rn_ifaces = panic "rnameSourceCode: rn_ifaces", -- Not required - rn_finder = panic "rnameSourceCode: rn_finder" -- Not required + rn_done = bogus "rn_done", rn_hit = bogus "rn_hit", + rn_ifaces = bogus "rn_ifaces", rn_finder = bogus "rn_finder" } s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc @@ -428,6 +427,8 @@ renameSourceCode dflags mod prs m where display errs = pprBagOfErrors errs +bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields + {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} {-# INLINE returnRn #-} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 00ba87c..fb0b5c6 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -19,8 +19,7 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, - recordLocalSlurps, checkModUsage, - outOfDate, findAndReadIface ) + recordLocalSlurps, findAndReadIface ) import RnEnv import RnMonad @@ -59,16 +58,15 @@ getGlobalNames :: RdrNameHsModule -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things GlobalRdrEnv, -- Maps just *local* things Avails, -- The exported stuff - AvailEnv, -- Maps a name to its parent AvailInfo + AvailEnv -- Maps a name to its parent AvailInfo -- Just for in-scope things only - Maybe ParsedIface -- The old interface file, if any )) -- Nothing => no need to recompile getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _, _)) -> + fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _)) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? @@ -132,19 +130,13 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) -- Found errors already, so exit now returnRn Nothing else - checkEarlyExit this_mod `thenRn` \ (up_to_date, old_iface) -> - if up_to_date then - -- Interface files are sufficiently unchanged - putDocRn (text "Compilation IS NOT required") `thenRn_` - returnRn Nothing - else -- PROCESS EXPORT LISTS exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> -- ALL DONE - returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface)) + returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env)) ) where all_imports = prel_imports ++ imports -- 1.7.10.4