X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=0fdd0554e0f89ffd3fcdfedc58a73cfd8e7808c2;hb=aa44169c3c01243cdbf38f50f58e80477586552c;hp=dcb715375b86a78096aa7eaf74d516caef9fda5e;hpb=861e836ed0cc1aa45932ecb3470967964440a0ef;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index dcb7153..0fdd055 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -15,14 +15,12 @@ import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) -import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports, - opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations, - opt_WarnUnusedBinds - ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports, +import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, + getInterfaceExports, getImportedRules, getSlurped, removeContext, loadBuiltinRules, getDeferredDecls, ImportDeclResult(..) ) @@ -33,12 +31,13 @@ import RnEnv ( availName, availsToNameSet, FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, mkSearchPath, moduleName, mkThisModule + moduleNameUserString, moduleName, mkModuleInThisPackage ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, - nameOccName, nameUnique, nameModule, maybeUserImportedFrom, - isUserImportedExplicitlyName, isUserImportedName, - maybeWiredInTyConName, maybeWiredInIdName, + nameOccName, nameUnique, nameModule, +-- maybeUserImportedFrom, +-- isUserImportedExplicitlyName, isUserImportedName, +-- maybeWiredInTyConName, maybeWiredInIdName, isUserExportedName, toRdrName, nameEnvElts, extendNameEnv ) @@ -49,9 +48,12 @@ 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 + ioTyCon_RDR, + unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, + eqString_RDR ) -import PrelInfo ( fractionalClassKeys, derivingOccurrences ) +import PrelInfo ( fractionalClassKeys, derivingOccurrences, + maybeWiredInTyConName, maybeWiredInIdName ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) import BasicTypes ( Version, initialVersion ) @@ -65,44 +67,55 @@ 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 \end{code} \begin{code} -type RenameResult = ( 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 +type RenameResult = ( PersistentCompilerState + , ModIface + ) -renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult) -renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc) +renameModule :: DynFlags -> Finder + -> PersistentCompilerState -> HomeSymbolTable + -> 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) = -- Initialise the renamer monad do { - ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) - <- initRn (mkThisModule mod_name) us - (mkSearchPath opt_HiMap) loc - (rename this_mod) ; + ((maybe_rn_stuff, dump_action), (rn_warns_bag, rn_errs_bag), new_pcs) + <- initRn dflags finder old_pcs hst loc (rename this_mod) ; -- Check for warnings - printErrorsAndWarnings rn_errs_bag rn_warns_bag ; + printErrorsAndWarnings (rn_warns_bag, rn_errs_bag) ; -- Dump any debugging output dump_action ; -- 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} \begin{code} -rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ()) +rename :: RdrNameHsModule -> RnMG (Maybe ModIface, IO ()) rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -154,7 +167,7 @@ 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 exports `thenRn` \ (my_exports, my_usages) -> + mkImportExportInfo mod_name export_avails imports `thenRn` \ (my_exports, my_usages) -> -- RETURN THE RENAMED MODULE getNameSupplyRn `thenRn` \ name_supply -> @@ -170,39 +183,26 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l user_import ImportByUserSource = True user_import _ = False - this_module = mkThisModule mod_name + this_module = mkModuleInThisPackage mod_name -- Export only those fixities that are for names that are -- (a) defined in this module -- (b) exported exported_fixities - = [ FixitySig (toRdrName name) fixity loc - | FixitySig name fixity loc <- nameEnvElts local_fixity_env, - isUserExportedName name - ] - - new_iface = ParsedIface { pi_mod = this_module - , pi_vers = initialVersion - , pi_orphan = any isOrphanDecl rn_local_decls - , pi_exports = my_exports - , pi_usages = my_usages - , pi_fixity = (initialVersion, exported_fixities) - , pi_deprecs = my_deprecs - -- These ones get filled in later - , pi_insts = [], pi_decls = [] - , pi_rules = (initialVersion, []) - } - - renamed_module = HsModule mod_name vers - trashed_exports trashed_imports - (rn_local_decls ++ rn_imp_decls) - mod_deprec - loc - - result = (this_module, renamed_module, - old_iface, new_iface, - name_supply, local_fixity_env, - direct_import_mods) + = mkNameEnv [ (name, fixity) + | FixitySig name fixity loc <- nameEnvElts local_fixity_env, + 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 + } in -- REPORT UNUSED NAMES, AND DEBUG DUMP @@ -211,7 +211,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l export_avails source_fvs rn_imp_decls `thenRn_` - returnRn (Just result, dump_action) } + returnRn (Just mod_iface, dump_action) } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] @@ -247,9 +247,10 @@ implicitFVs mod_name decls implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls -- Virtually every program has error messages in it somewhere - string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR] + string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, + eqString_RDR] - get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _)) + get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -469,8 +470,9 @@ slurpDeferredDecls decls ASSERT( isEmptyFVs fvs ) returnRn decls1 -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc)) +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc name1 name2)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc + name1 name2)) -- Nuke the context and constructors -- But retain the *number* of constructors! -- Also the tvs will have kinds on them. @@ -501,7 +503,7 @@ vars of the source program, and extracts from the decl the gate names. getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _)) +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ )) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (hsTyVarNames tvs) `addOneToNameSet` cls) @@ -526,7 +528,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (hsTyVarNames tvs) `addOneToNameSet` tycon @@ -594,29 +596,31 @@ getInstDeclGates other = emptyFVs \begin{code} fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv fixitiesFromLocalDecls gbl_env decls - = foldlRn getFixities emptyNameEnv decls `thenRn` \ env -> - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` + = doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused -> + foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env -> + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) + `thenRn_` returnRn env where - getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv - getFixities acc (FixD fix) - = fix_decl acc fix + getFixities :: Bool -> FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv + getFixities warn_uu acc (FixD fix) + = fix_decl warn_uu acc fix - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) - = foldlRn fix_decl acc [sig | FixSig sig <- sigs] + getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ )) + = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. - getFixities acc other_decl + getFixities warn_uu acc other_decl = returnRn acc - fix_decl acc sig@(FixitySig rdr_name fixity loc) + fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc) = -- Check for fixity decl for something not declared case lookupRdrEnv gbl_env rdr_name of { - Nothing | opt_WarnUnusedBinds + Nothing | warn_uu -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_` returnRn acc | otherwise -> returnRn acc ; - Just (name:_) -> + Just ((name,_):_) -> -- Check for duplicate fixity decl case lookupNameEnv acc name of { @@ -706,14 +710,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, @@ -768,25 +776,27 @@ 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_` warnUnusedImports bad_imp_names `thenRn_` printMinimalImports mod_name minimal_imports `thenRn_` getIfacesRn `thenRn` \ ifaces -> - (if opt_WarnDeprecations + doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> + (if warn_drs then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces)) else returnRn ()) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses printMinimalImports mod_name imps - | not opt_D_dump_minimal_imports + = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> + printMinimalImports_wrk dump_minimal mod_name imps + +printMinimalImports_wrk dump_minimal mod_name imps + | not dump_minimal = returnRn () | otherwise = mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> @@ -822,16 +832,16 @@ rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls -> RnMG (IO ()) rnDump imp_decls local_decls - | opt_D_dump_rn_trace || - opt_D_dump_rn_stats || - opt_D_dump_rn - = getRnStats imp_decls `thenRn` \ stats_msg -> - - returnRn (printErrs stats_msg >> - dumpIfSet opt_D_dump_rn "Renamer:" - (vcat (map ppr (local_decls ++ imp_decls)))) - - | otherwise = returnRn (return ()) + = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> + doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + if dump_rn_trace || dump_rn_stats || dump_rn then + getRnStats imp_decls `thenRn` \ stats_msg -> + returnRn (printErrs stats_msg >> + dumpIfSet dump_rn "Renamer:" + (vcat (map ppr (local_decls ++ imp_decls)))) + else + returnRn (return ()) \end{code}