X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=91a7b84129c653272ed03c75c93cee3bcccbf6bd;hb=301b341806ff4c6ad8e0c947530e0fbe9094caa7;hp=c3c8e4cd6cc16e3fdf0cf9adf6e1acd5296cfa63;hpb=1fb5dd7aae5dc87bbfc557f64eac7cee18914837;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c3c8e4c..91a7b84 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -1,63 +1,48 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1996 +% (c) The GRASP Project, Glasgow University, 1992-1998 % \section[Rename]{Renaming and dependency analysis passes} \begin{code} -#include "HsVersions.h" - module Rename ( renameModule ) where -#if __GLASGOW_HASKELL__ <= 201 -import PreludeGlaST ( thenPrimIO ) -#else -import GlaExts -import IO -#endif - -IMP_Ubiq() -IMPORT_1_3(List(partition)) +#include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) -import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames ) +import RdrHsSyn ( RdrName(..), RdrNameHsModule ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames ) -import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace, +import CmdLineOpts ( opt_HiMap, opt_D_show_rn_trace, opt_D_dump_rn, opt_D_show_rn_stats, - opt_D_show_unused_imports, opt_PprUserLength + opt_WarnUnusedBinds, opt_WarnUnusedImports ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnDecl ) +import RnSource ( rnIfaceDecl, rnSourceDecls ) import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, getDeferredDataDecls, mkSearchPath, getSlurpedNames, getRnStats ) -import RnEnv ( availsToNameSet, addAvailToNameSet, - addImplicitOccsRn, lookupImplicitOccRn ) -import Id ( GenId {- instance NamedThing -} ) -import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, - NameSet(..), elemNameSet, mkNameSet, unionNameSets, - nameSetToList, minusNameSet, NamedThing(..), - nameModule, pprModule, pprOccName, nameOccName +import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, warnUnusedTopNames ) +import Name ( Name, isLocallyDefined, + NamedThing(..), ImportReason(..), Provenance(..), + nameModule, pprModule, pprOccName, nameOccName, + getNameProvenance ) -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) -import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME ) +import NameSet import TyCon ( TyCon ) -import PrelMods ( mAIN, gHC_MAIN ) -import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, +import PrelMods ( mAIN, pREL_MAIN ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) +import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, doIfSet, dumpIfSet, ghcExit ) -import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) -import Pretty -import Outputable ( Outputable(..), PprStyle(..), - pprErrorsStyle, pprDumpStyle, printErrs - ) import Bag ( isEmptyBag ) -import Util ( cmpPString, equivClasses, panic, assertPanic, pprTrace ) -#if __GLASGOW_HASKELL__ >= 202 -import UniqSupply -#endif +import FiniteMap ( fmToList, delListFromFM ) +import UniqSupply ( UniqSupply ) +import Util ( equivClasses ) +import Maybes ( maybeToBool ) +import Outputable \end{code} @@ -65,12 +50,14 @@ import UniqSupply \begin{code} renameModule :: UniqSupply -> RdrNameHsModule - -> IO (Maybe (RenamedHsModule, -- Output, after renaming - InterfaceDetails, -- Interface; for interface file generatino - RnNameSupply, -- Final env; for renaming derivings - [Module])) -- Imported modules; for profiling - -renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc) + -> IO (Maybe + ( RenamedHsModule -- Output, after renaming + , InterfaceDetails -- Interface; for interface file generatino + , RnNameSupply -- Final env; for renaming derivings + , [Module] -- Imported modules; for profiling + )) + +renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) = -- Initialise the renamer monad initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) >>= @@ -78,11 +65,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ -- Check for warnings doIfSet (not (isEmptyBag rn_warns_bag)) - (print_errs rn_warns_bag) >> + (printErrs (pprBagOfWarnings rn_warns_bag)) >> -- Check for errors; exit if so doIfSet (not (isEmptyBag rn_errs_bag)) - (print_errs rn_errs_bag >> + (printErrs (pprBagOfErrors rn_errs_bag) >> ghcExit 1 ) >> @@ -91,46 +78,54 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ Nothing -> return () Just results@(rn_mod, _, _, _) -> dumpIfSet opt_D_dump_rn "Renamer:" - (ppr pprDumpStyle rn_mod) + (ppr rn_mod) ) >> -- Return results return maybe_rn_stuff - - -print_errs errs = printErrs (pprBagOfErrors pprErrorsStyle errs) \end{code} \begin{code} -rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod `thenRn` \ global_name_info -> - - case global_name_info of { - Nothing -> -- Everything is up to date; no need to recompile further - rnStats [] `thenRn_` - returnRn Nothing ; - - -- Otherwise, just carry on - Just (export_env, rn_env, explicit_names) -> +rename this_mod@(HsModule mod_name vers exports imports local_decls loc) + = -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_mod `thenRn` \ maybe_stuff -> + + -- CHECK FOR EARLY EXIT + if not (maybeToBool maybe_stuff) then + -- Everything is up to date; no need to recompile further + rnStats [] `thenRn_` + returnRn Nothing + else + let + Just (export_env, rn_env, global_avail_env) = maybe_stuff + in -- RENAME THE SOURCE initRnMS rn_env mod_name SourceMode ( addImplicits mod_name `thenRn_` - mapRn rnDecl local_decls - ) `thenRn` \ rn_local_decls -> + rnSourceDecls local_decls + ) `thenRn` \ (rn_local_decls, fvs) -> -- SLURP IN ALL THE NEEDED DECLARATIONS - slurpDecls rn_local_decls `thenRn` \ rn_all_decls -> + slurpDecls rn_local_decls `thenRn` \ rn_all_decls -> + -- EXIT IF ERRORS FOUND + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnStats [] `thenRn_` + returnRn Nothing + else -- GENERATE THE VERSION/USAGE INFO getImportVersions mod_name exports `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> -- REPORT UNUSED NAMES - reportUnusedNames explicit_names `thenRn_` + reportUnusedNames rn_env global_avail_env + export_env + fvs `thenRn_` -- GENERATE THE SPECIAL-INSTANCE MODULE LIST -- The "special instance" modules are those modules that contain instance @@ -151,7 +146,7 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] renamed_module = HsModule mod_name vers - trashed_exports trashed_imports trashed_fixities + trashed_exports trashed_imports rn_all_decls loc in @@ -160,11 +155,9 @@ rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc (import_versions, export_env, special_inst_mods), name_supply, import_mods)) - } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] - trashed_fixities = [] \end{code} @addImplicits@ forces the renamer to slurp in some things which aren't @@ -172,18 +165,18 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} addImplicits mod_name - = addImplicitOccsRn (implicit_main ++ default_tys) + = addImplicitOccsRn (implicit_main ++ default_tys ++ thinAirIdNames) where -- Add occurrences for Int, Double, and (), because they -- are the types to which ambigious type variables may be defaulted by - -- the type checker; so they won't every appear explicitly. + -- the type checker; so they won't always appear explicitly. -- [The () one is a GHC extension for defaulting CCall results.] - default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon] + default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ] -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN = [ioTyCon_NAME] - | mod_name == gHC_MAIN = [primIoTyCon_NAME] - | otherwise = [] + implicit_main | mod_name == mAIN + || mod_name == pREL_MAIN = [ioTyCon_NAME] + | otherwise = [] \end{code} @@ -193,16 +186,19 @@ slurpDecls decls slurp_compulsories decls `thenRn` \ decls1 -> -- Next get the optional ones - closeDecls Optional decls1 `thenRn` \ decls2 -> + closeDecls optional_mode decls1 `thenRn` \ decls2 -> -- Finally get those deferred data type declarations - getDeferredDataDecls `thenRn` \ data_decls -> - mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls -> + getDeferredDataDecls `thenRn` \ data_decls -> + mapRn (rn_data_decl compulsory_mode) data_decls `thenRn` \ rn_data_decls -> -- Done returnRn (rn_data_decls ++ decls2) where + compulsory_mode = InterfaceMode Compulsory + optional_mode = InterfaceMode Optional + -- The "slurp_compulsories" function is a loop that alternates -- between slurping compulsory decls and slurping the instance -- decls thus made relavant. @@ -215,7 +211,7 @@ slurpDecls decls -- whose decl we must slurp, which might let in some new instance decls, -- and so on. Example: instance Foo a => Baz [a] where ... slurp_compulsories decls - = closeDecls Compulsory decls `thenRn` \ decls1 -> + = closeDecls compulsory_mode decls `thenRn` \ decls1 -> -- Instance decls still pending? getImportedInstDecls `thenRn` \ inst_decls -> @@ -225,80 +221,98 @@ slurpDecls decls else -- Yes, there are some, so rename them and loop traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")]) - `thenRn_` - mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> + `thenRn_` + mapRn (rn_inst_decl compulsory_mode) inst_decls `thenRn` \ new_inst_decls -> slurp_compulsories (new_inst_decls ++ decls1) \end{code} \begin{code} -closeDecls :: Necessity +closeDecls :: RnSMode -> [RenamedHsDecl] -- Declarations got so far -> RnMG [RenamedHsDecl] -- input + extra decls slurped -- The monad includes a list of possibly-unresolved Names -- This list is empty when closeDecls returns -closeDecls necessity decls - = popOccurrenceName necessity `thenRn` \ maybe_unresolved -> +closeDecls mode decls + = popOccurrenceName mode `thenRn` \ maybe_unresolved -> case maybe_unresolved of -- No more unresolved names Nothing -> returnRn decls -- An unresolved name - Just name + Just name_w_loc -> -- Slurp its declaration, if any --- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_` - importDecl name necessity `thenRn` \ maybe_decl -> +-- traceRn (sep [ptext SLIT("Considering"), ppr name_w_loc]) `thenRn_` + importDecl name_w_loc mode `thenRn` \ maybe_decl -> case maybe_decl of -- No declaration... (wired in thing or optional) - Nothing -> closeDecls necessity decls + Nothing -> closeDecls mode decls -- Found a declaration... rename it - Just decl -> rn_iface_decl mod_name necessity decl `thenRn` \ new_decl -> - closeDecls necessity (new_decl : decls) + Just decl -> rn_iface_decl mod_name mode decl `thenRn` \ new_decl -> + closeDecls mode (new_decl : decls) where - mod_name = nameModule name + mod_name = nameModule (fst name_w_loc) - -rn_iface_decl mod_name necessity decl -- Notice that the rnEnv starts empty - = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) (rnDecl decl) +rn_iface_decl mod_name mode decl + = initRnMS emptyRnEnv mod_name mode (rnIfaceDecl decl) -rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name Compulsory (InstD decl) - -rn_data_decl (tycon_name,ty_decl) = rn_iface_decl mod_name Compulsory (TyD ty_decl) - where - mod_name = nameModule tycon_name +rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl) +rn_data_decl mode (mod_name,ty_decl) = rn_iface_decl mod_name mode (TyClD ty_decl) \end{code} \begin{code} -reportUnusedNames explicit_avail_names - | not opt_D_show_unused_imports +reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentioned_names + | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) = returnRn () | otherwise - = getSlurpedNames `thenRn` \ slurped_names -> - let - unused = explicit_avail_names `minusNameSet` slurped_names - (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused) - imports_by_module = equivClasses cmp imported_unused - name1 `cmp` name2 = nameModule name1 `_CMP_STRING_` nameModule name2 - - pp_imp sty = sep [text "For information: the following unqualified imports are unused:", - nest 4 (vcat (map (pp_group sty) imports_by_module))] - pp_group sty (n:ns) = sep [hcat [text "Module ", pprModule (PprForUser opt_PprUserLength) (nameModule n), char ':'], - nest 4 (sep (map (pprOccName sty . nameOccName) (n:ns)))] - - pp_local sty = sep [text "For information: the following local top-level definitions are unused:", - nest 4 (sep (map (pprOccName sty . nameOccName) local_unused))] + = 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 avail + | sub_name <- nameSetToList used_names, + let avail = case lookupNameEnv avail_env sub_name of + Just avail -> avail + Nothing -> pprTrace "r.u.n" (ppr sub_name) $ + Avail sub_name + ] + + defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) + defined_but_not_used = defined_names `minusNameSet` really_used_names + + -- Filter out the ones only defined implicitly or whose OccNames + -- start with an '_', which we won't report. + bad_guys = filter is_explicit (nameSetToList defined_but_not_used) + is_explicit n = case getNameProvenance n of + LocalDef _ _ -> True + NonLocalDef (UserImport _ _ explicit) _ _ -> explicit + other -> False + + -- Now group by whether locally defined or imported; + -- one group is the locally-defined ones, one group per import module + groups = equivClasses cmp bad_guys + where + name1 `cmp` name2 = getNameProvenance name1 `cmph` getNameProvenance name2 + + cmph (LocalDef _ _) (NonLocalDef _ _ _) = LT + cmph (LocalDef _ _) (LocalDef _ _) = EQ + cmph (NonLocalDef (UserImport m1 _ _) _ _) + (NonLocalDef (UserImport m2 _ _) _ _) + = m1 `compare` m2 + cmph (NonLocalDef _ _ _) (LocalDef _ _) = GT + -- In-scope NonLocalDefs must have UserImport info on them + + -- ToDo: report somehow on T(..) things where no constructors + -- are imported in - (if null imported_unused - then returnRn () - else addWarnRn pp_imp) `thenRn_` - - (if null local_unused - then returnRn () - else addWarnRn pp_local) + mapRn warnUnusedTopNames groups `thenRn_` + returnRn () rnStats :: [RenamedHsDecl] -> RnMG () rnStats all_decls