X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=5474e172a2f1ae8a539773f697fe10ee51f9f211;hb=94ff1ec1546169fc839b2318c0d141f3089d3e26;hp=cd531b8fc5b70f155b56872ee7e2f0af5c1fd46e;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index cd531b8..5474e17 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -1,42 +1,53 @@ % -% (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 -import PreludeGlaST ( thenPrimIO ) - -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 ( RdrNameHsModule ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames ) -import CmdLineOpts ( opt_HiMap ) +import CmdLineOpts ( opt_HiMap, opt_D_show_rn_trace, + opt_D_dump_rn, opt_D_show_rn_stats, + opt_WarnUnusedBinds, opt_WarnUnusedImports + ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnDecl ) -import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules, - mkSearchPath, getWiredInDecl +import RnSource ( rnIfaceDecl, rnSourceDecls ) +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, + getDeferredDataDecls, + mkSearchPath, getSlurpedNames, getRnStats ) -import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn ) -import Id ( GenId {- instance NamedThing -} ) -import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, - NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList, - isWiredInName, modAndOcc +import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, + warnUnusedTopNames ) -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import Module ( pprModule ) +import Name ( Name, isLocallyDefined, + NamedThing(..), ImportReason(..), Provenance(..), + nameModule, pprOccName, nameOccName, + getNameProvenance, occNameUserString, + ) +import RdrName ( RdrName ) +import NameSet import TyCon ( TyCon ) -import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) -import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) -import Pretty -import PprStyle ( PprStyle(..) ) -import Util ( panic, assertPanic, pprTrace ) +import PrelMods ( mAIN, pREL_MAIN ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) +import Type ( funTyCon ) +import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, + doIfSet, dumpIfSet, ghcExit + ) +import Bag ( isEmptyBag ) +import FiniteMap ( fmToList, delListFromFM ) +import UniqSupply ( UniqSupply ) +import Util ( equivClasses ) +import Maybes ( maybeToBool ) +import Outputable \end{code} @@ -44,69 +55,82 @@ import Util ( panic, assertPanic, pprTrace ) \begin{code} renameModule :: UniqSupply -> RdrNameHsModule - -> IO (Maybe -- Nothing <=> everything up to date; - -- no ned to recompile any further - (RenamedHsModule, -- Output, after renaming - InterfaceDetails, -- Interface; for interface file generatino - RnNameSupply, -- Final env; for renaming derivings - [Module]), -- Imported modules; for profiling - Bag Error, - Bag Warning - ) -\end{code} + -> 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) >>= + \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> + + -- Check for warnings + doIfSet (not (isEmptyBag rn_warns_bag)) + (printErrs (pprBagOfWarnings rn_warns_bag)) >> + + -- Check for errors; exit if so + doIfSet (not (isEmptyBag rn_errs_bag)) + (printErrs (pprBagOfErrors rn_errs_bag) >> + ghcExit 1 + ) >> + + -- Dump output, if any + (case maybe_rn_stuff of + Nothing -> return () + Just results@(rn_mod, _, _, _) + -> dumpIfSet opt_D_dump_rn "Renamer:" + (ppr rn_mod) + ) >> + + -- Return results + return maybe_rn_stuff +\end{code} \begin{code} -renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc) - = -- INITIALISE THE RENAMER MONAD - initRn mod_name us (mkSearchPath opt_HiMap) 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 - returnRn Nothing ; - - -- Otherwise, just carry on - Just (export_env, rn_env, local_avails) -> +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 - -- We also 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 () one is a GHC extension for defaulting CCall results.] - initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls -> - addImplicitOccsRn [getName intTyCon, - getName doubleTyCon, - getName unitTyCon] `thenRn_` + initRnMS rn_env SourceMode ( + addImplicits mod_name `thenRn_` + rnSourceDecls local_decls + ) `thenRn` \ (rn_local_decls, fvs) -> -- SLURP IN ALL THE NEEDED DECLARATIONS - -- Notice that the rnEnv starts empty - closeDecls rn_local_decls (availsToNameSet local_avails) [] - `thenRn` \ (rn_all_decls, imported_avails) -> - - -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS - -- We keep the ones that only mention things (type constructors, classes) that are - -- already imported. Ones which don't can't possibly be useful to us. - getImportedInstDecls `thenRn` \ imported_insts -> - let - all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets` - mkNameSet [name | Avail name _ <- imported_avails] - - rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl)) - | (inst_names, mod_name, inst_decl) <- imported_insts, - all (`elemNameSet` all_big_names) inst_names - ] - in - sequenceRn rn_needed_insts `thenRn` \ inst_decls -> - -- Maybe we need to do another close-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 imported_avails `thenRn` \ import_versions -> + getImportVersions mod_name exports `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> + -- REPORT UNUSED NAMES + 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 @@ -122,79 +146,185 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ in - -- RETURN THE RENAMED MODULE let import_mods = [mod | ImportDecl mod _ _ _ _ <- imports] renamed_module = HsModule mod_name vers - trashed_exports trashed_imports trashed_fixities - (inst_decls ++ rn_all_decls) + trashed_exports trashed_imports + rn_all_decls loc in + rnStats rn_all_decls `thenRn_` returnRn (Just (renamed_module, (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 +mentioned explicitly, but which might be needed by the type checker. + \begin{code} -closeDecls :: [RenamedHsDecl] -- Declarations got so far - -> NameSet -- Names bound by those declarations - -> [AvailInfo] -- Available stuff generated by closeDecls so far - -> RnMG ([RenamedHsDecl], -- The closed set - [AvailInfo]) -- Available stuff generated by closeDecls - -- The monad includes a list of possibly-unresolved Names - -- This list is empty when closeDecls returns +addImplicits mod_name + = 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 always appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + -- ALSO: funTyCon, since it occurs implicitly everywhere! + -- (we don't want to be bothered with addImplicitOcc at every + -- function application) + default_tys = [getName intTyCon, getName doubleTyCon, + getName unitTyCon, getName funTyCon] + + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN + || mod_name == pREL_MAIN = [ioTyCon_NAME] + | otherwise = [] +\end{code} -closeDecls decls decl_names import_avails - = popOccurrenceName `thenRn` \ maybe_unresolved -> - case maybe_unresolved of +\begin{code} +slurpDecls decls + = -- First of all, get all the compulsory decls + slurp_compulsories decls `thenRn` \ decls1 -> - -- No more unresolved names; we're done - Nothing -> returnRn (decls, import_avails) + -- Next get the optional ones + closeDecls optional_mode decls1 `thenRn` \ decls2 -> - -- An "unresolved" name that we've already dealt with - Just (name,_) | name `elemNameSet` decl_names - -> closeDecls decls decl_names import_avails + -- Finally get those deferred data type declarations + 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. + -- We *must* loop again here. Why? Two reasons: + -- (a) an instance decl will give rise to an unresolved dfun, whose + -- decl we must slurp to get its version number; that's the version + -- number for the whole instance decl. (And its unfolding might mention new + -- unresolved names.) + -- (b) an instance decl might give rise to a new unresolved class, + -- 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_mode decls `thenRn` \ decls1 -> - -- An unresolved name that's wired in. In this case there's no - -- declaration to get, but we still want to record it as now available, - -- so that we remember to look for instance declarations involving it. - Just (name,_) | isWiredInName name - -> getWiredInDecl name `thenRn` \ decl_avail -> - closeDecls decls - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) - - -- Genuinely unresolved name - Just (name,necessity) | otherwise - -> getDecl name `thenRn` \ (decl_avail,new_decl) -> - case decl_avail of - - -- Can't find the declaration; check that it was optional - NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False}) - (getDeclErr name) `thenRn_` - closeDecls decls decl_names import_avails - - -- Found it - other -> initRnMS emptyRnEnv mod_name InterfaceMode ( - rnDecl new_decl - ) `thenRn` \ rn_decl -> - closeDecls (rn_decl : decls) - (addAvailToNameSet decl_names decl_avail) - (decl_avail : import_avails) - where - (mod_name,_) = modAndOcc name - -getDeclErr name sty - = ppSep [ppStr "Failed to find interface decl for", ppr sty name] + -- Instance decls still pending? + getImportedInstDecls `thenRn` \ inst_decls -> + if null inst_decls then + -- No, none + returnRn decls1 + 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 compulsory_mode) inst_decls `thenRn` \ new_inst_decls -> + slurp_compulsories (new_inst_decls ++ decls1) +\end{code} + +\begin{code} +closeDecls :: RnMode + -> [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 mode decls + = popOccurrenceName mode `thenRn` \ maybe_unresolved -> + case maybe_unresolved of + + -- No more unresolved names + Nothing -> returnRn decls + + -- An unresolved name + Just name_w_loc + -> -- Slurp its declaration, if any +-- 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 mode decls + + -- Found a declaration... rename it + Just decl -> rn_iface_decl mod_name mode decl `thenRn` \ new_decl -> + closeDecls mode (new_decl : decls) + where + mod_name = nameModule (fst name_w_loc) + +rn_iface_decl mod_name mode decl + = setModuleRn mod_name $ + initRnMS emptyRnEnv mode (rnIfaceDecl decl) + +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 (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentioned_names + | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) + = returnRn () + + | otherwise + = 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 = nameSetToList (defined_names `minusNameSet` really_used_names) + + -- Filter out the ones only defined implicitly + bad_guys = filter reportableUnusedName defined_but_not_used + in + warnUnusedTopNames bad_guys `thenRn_` + returnRn () + +reportableUnusedName :: Name -> Bool +reportableUnusedName name + = explicitlyImported (getNameProvenance name) && + not (startsWithUnderscore (occNameUserString (nameOccName name))) + where + explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars + explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports + explicitlyImported other = False -- Don't report others + + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". + startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting + startsWithUnderscore other = False -- with an underscore + +rnStats :: [RenamedHsDecl] -> RnMG () +rnStats all_decls + | opt_D_show_rn_trace || + opt_D_show_rn_stats || + opt_D_dump_rn + = getRnStats all_decls `thenRn` \ msg -> + ioToRnMG (printErrs msg) `thenRn_` + returnRn () + + | otherwise = returnRn () +\end{code}