X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=67195e25ac77f6c90e562246c27bf49e93a819ab;hb=7d7d186e02f0c86efb7fc9291a142b30005718ae;hp=edec9523d91a48eb131255529ea0ddbdf1dca456;hpb=47eef4b5780f0a5b5a37847097842daebd0f9285;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index edec952..67195e2 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,41 +4,41 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( renameModule, closeIfaceDecls, checkOldIface ) where +module Rename ( renameModule, renameExpr, closeIfaceDecls, checkOldIface ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameHsExpr, RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - extractHsTyNames, + extractHsTyNames, RenamedHsExpr, instDeclFVs, tyClDeclFVs, ruleDeclFVs ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad -import RnNames ( getGlobalNames ) +import RnExpr ( rnExpr ) +import RnNames ( getGlobalNames, exportsFromAvail ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) -import RnIfaces ( slurpImpDecls, mkImportInfo, +import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, getInterfaceExports, closeDecls, RecompileRequired, outOfDate, recompileRequired ) -import RnHiFiles ( readIface, removeContext, +import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs ) -import RnEnv ( availName, +import RnEnv ( availsToNameSet, availName, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupSrcName, newGlobalName + lookupOrigNames, lookupSrcName, newGlobalName, unQualInScope ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, - mkModuleInThisPackage, mkModuleName, moduleEnvElts + moduleEnvElts, lookupModuleEnv ) import Name ( Name, NamedThing(..), getSrcLoc, - nameIsLocalOrFrom, - nameOccName, nameModule, + nameIsLocalOrFrom, nameOccName, nameModule, ) import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) import RdrName ( elemRdrEnv, foldRdrEnv, isQual ) @@ -46,13 +46,13 @@ import OccName ( occNameFlavour ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyCon_RDR, main_RDR, + ioTyCon_RDR, main_RDR_Unqual, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) import PrelInfo ( derivingOccurrences ) import Type ( funTyCon ) -import ErrUtils ( dumpIfSet ) +import ErrUtils ( dumpIfSet, showPass, printErrorsAndWarnings, errorsFound ) import Bag ( bagToList ) import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM, addToFM_C, elemFM, addToFM @@ -63,8 +63,10 @@ import Outputable import IO ( openFile, IOMode(..) ) import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, ModIface(..), WhatsImported(..), - VersionInfo(..), ImportVersion, IfaceDecls(..), - GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, + VersionInfo(..), ImportVersion, IsExported, + IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, + GlobalRdrEnv, pprGlobalRdrEnv, + AvailEnv, GenAvailInfo(..), AvailInfo, Avails, Provenance(..), ImportReason(..), initialVersionInfo, Deprecations(..), lookupDeprec, lookupIface ) @@ -73,9 +75,10 @@ import List ( partition, nub ) + %********************************************************* %* * -\subsection{The main function: rename} +\subsection{The two main wrappers} %* * %********************************************************* @@ -84,31 +87,85 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) + -- Nothing => some error occurred in the renamer + +renameModule dflags hit hst pcs this_module rdr_module + = renameSource dflags hit hst pcs this_module $ + rename this_module rdr_module +\end{code} + + +\begin{code} +renameExpr :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module -> RdrNameHsExpr + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))) + +renameExpr dflags hit hst pcs this_module expr + | Just iface <- lookupModuleEnv hit this_module + = do { let rdr_env = mi_globals iface + ; let print_unqual = unQualInScope rdr_env + + ; renameSource dflags hit hst pcs this_module $ + initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) -> + slurpImpDecls fvs `thenRn` \ decls -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_` + returnRn (Just (print_unqual, (e, decls))) + } + + | otherwise + = do { printErrs alwaysQualify (ptext SLIT("renameExpr: Bad module context") <+> ppr this_module) + ; return (pcs, Nothing) + } +\end{code} + + +%********************************************************* +%* * +\subsection{The main function: rename} +%* * +%********************************************************* + +\begin{code} +renameSource :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module + -> RnMG (Maybe (PrintUnqualified, r)) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r)) -- Nothing => some error occurred in the renamer -renameModule dflags hit hst old_pcs this_module rdr_module - = -- Initialise the renamer monad - do { - (new_pcs, errors_found, maybe_rn_stuff) - <- initRn dflags hit hst old_pcs this_module (rename this_module rdr_module) ; +renameSource dflags hit hst old_pcs this_module thing_inside + = do { showPass dflags "Renamer" + + -- Initialise the renamer monad + ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside + + -- Print errors from renaming + ; let print_unqual = case maybe_rn_stuff of + Just (unqual, _) -> unqual + Nothing -> alwaysQualify - -- Return results. No harm in updating the PCS - if errors_found then + ; printErrorsAndWarnings print_unqual msgs ; + + -- Return results. No harm in updating the PCS + ; if errorsFound msgs then return (new_pcs, Nothing) - else + else return (new_pcs, maybe_rn_stuff) } \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl])) -rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) +rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, - export_avails, global_avail_env) -> + getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, all_avails@(_, global_avail_env)) -> -- Exit if we've found any errors checkErrsRn `thenRn` \ no_errs_so_far -> @@ -118,6 +175,12 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) returnRn Nothing else + -- PROCESS EXPORT LIST + exportsFromAvail mod_name exports all_avails gbl_env `thenRn` \ export_avails -> + + traceRn (text "Local top-level environment" $$ + nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_` + -- DEAL WITH DEPRECATIONS rnDeprecs local_gbl_env mod_deprec [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> @@ -126,9 +189,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> -- RENAME THE SOURCE - initRnMS gbl_env local_fixity_env SourceMode ( - rnSourceDecls local_decls - ) `thenRn` \ (rn_local_decls, source_fvs) -> + rnSourceDecls gbl_env local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) -> -- CHECK THAT main IS DEFINED, IF REQUIRED checkMain this_module local_gbl_env `thenRn_` @@ -136,15 +197,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let - -- The export_fvs make the exported names look just as if they - -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.getImportVersions. - -- We only need the 'parent name' of the avail; - -- that's enough to suck in the declaration. - export_fvs = mkNameSet (map availName export_avails) - real_source_fvs = source_fvs `plusFV` export_fvs - - slurp_fvs = implicit_fvs `plusFV` real_source_fvs + slurp_fvs = implicit_fvs `plusFV` source_fvs -- It's important to do the "plus" this way round, so that -- when compiling the prelude, locally-defined (), Bool, etc -- override the implicit ones. @@ -179,7 +232,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) mod_iface = ModIface { mi_module = this_module, mi_version = initialVersionInfo, - mi_usages = my_usages, + mi_usages = my_usages, mi_boot = False, mi_orphan = is_orphan, mi_exports = my_exports, @@ -188,13 +241,18 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) mi_deprecs = my_deprecs, mi_decls = panic "mi_decls" } + + print_unqualified = unQualInScope gbl_env + is_exported name = name `elemNameSet` exported_names + exported_names = availsToNameSet export_avails in -- REPORT UNUSED NAMES, AND DEBUG DUMP - reportUnusedNames mod_iface imports global_avail_env - real_source_fvs rn_imp_decls `thenRn_` + reportUnusedNames mod_iface print_unqualified + imports global_avail_env + source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (mod_iface, final_decls)) + returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls))) where mod_name = moduleName this_module \end{code} @@ -205,7 +263,7 @@ Checking that main is defined checkMain :: Module -> GlobalRdrEnv -> RnMG () checkMain this_mod local_env | moduleName this_mod == mAIN_Name - = checkRn (main_RDR `elemRdrEnv` local_env) noMainErr + = checkRn (main_RDR_Unqual `elemRdrEnv` local_env) noMainErr | otherwise = returnRn () \end{code} @@ -368,18 +426,20 @@ checkOldIface :: DynFlags -- True <=> errors happened checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface - = case maybe_iface of + = runRn dflags hit hst pcs (panic "Bogus module") $ + case maybe_iface of Just old_iface -> -- Use the one we already have - startRn (mi_module old_iface) $ - check_versions old_iface + setModuleRn (mi_module old_iface) (check_versions old_iface) + Nothing -- try and read it from a file - -> do read_result <- readIface do_traceRn iface_path - case read_result of - Left err -> -- Old interface file not found, or garbled; give up - do { ioTraceRn (text "Bad old interface file" $$ nest 4 err) ; - return (pcs, False, (outOfDate, Nothing)) } - Right parsed_iface - -> startRn (pi_mod parsed_iface) $ + -> readIface iface_path `thenRn` \ read_result -> + case read_result of + Left err -> -- Old interface file not found, or garbled; give up + traceRn (text "Bad old interface file" $$ nest 4 err) `thenRn_` + returnRn (outOfDate, Nothing) + + Right parsed_iface + -> setModuleRn (pi_mod parsed_iface) $ loadOldIface parsed_iface `thenRn` \ m_iface -> check_versions m_iface where @@ -389,10 +449,6 @@ checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface recompileRequired iface_path source_unchanged iface `thenRn` \ recompile -> returnRn (recompile, Just iface) - - do_traceRn = dopt Opt_D_dump_rn_trace dflags - ioTraceRn sdoc = if do_traceRn then printErrs sdoc else return () - startRn mod = initRn dflags hit hst pcs mod \end{code} I think the following function should now have a more representative name, @@ -403,9 +459,7 @@ loadOldIface :: ParsedIface -> RnMG ModIface loadOldIface parsed_iface = let iface = parsed_iface - in -- RENAME IT - let mod = pi_mod iface - doc_str = ptext SLIT("need usage info from") <+> ppr mod + mod = pi_mod iface in initIfaceRnMS mod ( loadHomeDecls (pi_decls iface) `thenRn` \ decls -> @@ -425,16 +479,14 @@ loadOldIface parsed_iface vers_rules = rule_vers, vers_decls = decls_vers } - decls = IfaceDecls { dcl_tycl = new_decls, - dcl_rules = new_rules, - dcl_insts = new_insts } + decls = mkIfaceDecls new_decls new_rules new_insts mod_iface = ModIface { mi_module = mod, mi_version = version, mi_exports = avails, mi_usages = usages, mi_boot = False, mi_orphan = pi_orphan iface, mi_fixities = fix_env, mi_deprecs = deprec_env, mi_decls = decls, - mi_globals = panic "No mi_globals in old interface" + mi_globals = mkIfaceGlobalRdrEnv avails } in returnRn mod_iface @@ -499,7 +551,7 @@ closeIfaceDecls :: DynFlags -- True <=> errors happened closeIfaceDecls dflags hit hst pcs mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) - = initRn dflags hit hst pcs mod $ + = runRn dflags hit hst pcs mod $ let rule_decls = dcl_rules iface_decls @@ -511,7 +563,10 @@ closeIfaceDecls dflags hit hst pcs needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` unionManyNameSets (map tyClDeclFVs tycl_decls) + local_names = foldl add emptyNameSet tycl_decls + add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl)) in + recordLocalSlurps local_names `thenRn_` closeDecls decls needed \end{code} @@ -522,26 +577,32 @@ closeIfaceDecls dflags hit hst pcs %********************************************************* \begin{code} -reportUnusedNames :: ModIface -> [RdrNameImportDecl] +reportUnusedNames :: ModIface -> PrintUnqualified + -> [RdrNameImportDecl] -> AvailEnv - -> NameSet + -> NameSet -- Used in this module + -> Avails -- Exported by this module -> [RenamedHsDecl] -> RnMG () -reportUnusedNames my_mod_iface imports avail_env - used_names imported_decls +reportUnusedNames my_mod_iface unqual imports avail_env + source_fvs export_avails imported_decls = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports this_mod minimal_imports `thenRn_` - warnDeprecations this_mod my_deprecs really_used_names `thenRn_` - traceRn (text "Used" <+> fsep (map ppr (nameSetToList used_names))) `thenRn_` - returnRn () + printMinimalImports this_mod unqual minimal_imports `thenRn_` + warnDeprecations this_mod export_avails my_deprecs + really_used_names where this_mod = mi_module my_mod_iface gbl_env = mi_globals my_mod_iface my_deprecs = mi_deprecs my_mod_iface + -- The export_fvs make the exported names look just as if they + -- occurred in the source program. + export_fvs = availsToNameSet export_avails + used_names = source_fvs `plusFV` export_fvs + -- 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` @@ -577,7 +638,7 @@ reportUnusedNames my_mod_iface imports avail_env 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, + 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 @@ -610,9 +671,9 @@ reportUnusedNames my_mod_iface imports avail_env 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 + 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] @@ -638,13 +699,17 @@ reportUnusedNames my_mod_iface imports avail_env module_unused :: Module -> Bool module_unused mod = moduleName mod `elem` unused_imp_mods - -warnDeprecations this_mod my_deprecs used_names +warnDeprecations this_mod export_avails my_deprecs used_names = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> if not warn_drs then returnRn () else - getIfacesRn `thenRn` \ ifaces -> - getHomeIfaceTableRn `thenRn` \ hit -> + -- The home modules for things in the export list + -- may not have been loaded yet; do it now, so + -- that we can see their deprecations, if any + mapRn_ load_home export_mods `thenRn_` + + getIfacesRn `thenRn` \ ifaces -> + getHomeIfaceTableRn `thenRn` \ hit -> let pit = iPIT ifaces deprecs = [ (n,txt) @@ -654,22 +719,29 @@ warnDeprecations this_mod my_deprecs used_names mapRn_ warnDeprec deprecs where + export_mods = nub [ moduleName (nameModule name) + | avail <- export_avails, + let name = availName avail, + not (nameIsLocalOrFrom this_mod name) ] + + load_home m = loadInterface (text "Check deprecations for" <+> ppr m) m ImportBySystem + lookup_deprec hit pit n | nameIsLocalOrFrom this_mod n = lookupDeprec my_deprecs n | otherwise - = case lookupIface hit pit this_mod n of + = case lookupIface hit pit n of Just iface -> lookupDeprec (mi_deprecs iface) n Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports this_mod imps +printMinimalImports this_mod unqual imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> ioToRnM (do { h <- openFile filename WriteMode ; - printForUser h (vcat (map ppr_mod_ie mod_ies)) + printForUser h unqual (vcat (map ppr_mod_ie mod_ies)) }) `thenRn_` returnRn () where @@ -753,26 +825,13 @@ getRnStats imported_decls ifaces stats = vcat [int n_mods <+> text "interfaces read", - hsep [ int n_decls_slurped, text "class decls imported, out of", + hsep [ int n_decls_slurped, text "type/class/variable imported, out of", int (n_decls_slurped + n_decls_left), text "read"], hsep [ int n_insts_slurped, text "instance decls imported, out of", int (n_insts_slurped + n_insts_left), text "read"], hsep [ int n_rules_slurped, text "rule decls imported, out of", int (n_rules_slurped + n_rules_left), text "read"] ] - -count_decls decls - = (class_decls, - data_decls, - newtype_decls, - syn_decls, - val_decls, - inst_decls) - where - tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls, val_decls) = countTyClDecls tycl_decls - - inst_decls = length [() | InstD _ <- decls] \end{code}