X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=c3c8e4cd6cc16e3fdf0cf9adf6e1acd5296cfa63;hb=1fb5dd7aae5dc87bbfc557f64eac7cee18914837;hp=1a969990e33a1d3ff51d088e2d32fc3face95357;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 1a96999..c3c8e4c 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,275 +8,307 @@ module Rename ( renameModule ) where -import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) ) +#if __GLASGOW_HASKELL__ <= 201 +import PreludeGlaST ( thenPrimIO ) +#else +import GlaExts +import IO +#endif -import Ubiq +IMP_Ubiq() +IMPORT_1_3(List(partition)) import HsSyn -import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) -import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired ) - ---ToDo:rm: all for debugging only -import Maybes -import Name -import Outputable -import RnIfaces -import PprStyle -import Pretty -import FiniteMap -import Util (pprPanic, pprTrace) +import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) +import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames ) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), - UsagesMap(..), VersionsMap(..) - ) +import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace, + opt_D_dump_rn, opt_D_show_rn_stats, + opt_D_show_unused_imports, opt_PprUserLength + ) import RnMonad -import RnNames ( getGlobalNames, GlobalNameInfo(..) ) -import RnSource ( rnSource ) -import RnIfaces ( rnIfaces ) -import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) - -import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiMap ) -import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) -import Maybes ( catMaybes ) -import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) ) -import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( pRELUDE ) -import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) -import UniqSupply ( splitUniqSupply ) -import Util ( panic, assertPanic ) +import RnNames ( getGlobalNames ) +import RnSource ( rnDecl ) +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 TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) +import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME ) +import TyCon ( TyCon ) +import PrelMods ( mAIN, gHC_MAIN ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors, + 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 \end{code} + + \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) + = -- 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)) + (print_errs rn_warns_bag) >> + + -- Check for errors; exit if so + doIfSet (not (isEmptyBag rn_errs_bag)) + (print_errs 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 pprDumpStyle rn_mod) + ) >> + + -- Return results + return maybe_rn_stuff + + +print_errs errs = printErrs (pprBagOfErrors pprErrorsStyle errs) +\end{code} - -> IO (RenamedHsModule, -- output, after renaming - RnEnv, -- final env (for renaming derivings) - [Module], -- imported modules; for profiling - - (UsagesMap, - VersionsMap, -- version info; for usage - [Module]), -- instance modules; for iface - - Bag Error, - Bag Warning) -\end{code} - -ToDo: May want to arrange to return old interface for this module! -ToDo: Builtin names which must be read. -ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} -renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) +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 -> - = let - (b_names, b_keys, _) = builtinNameInfo - in - --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> - -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids)) - -- , ppCat (map ppPStr (keysFM builtin_tcs)) - -- , ppCat (map ppPStr (keysFM b_keys)) - -- ]}) $ + case global_name_info of { + Nothing -> -- Everything is up to date; no need to recompile further + rnStats [] `thenRn_` + returnRn Nothing ; - makeHiMap opt_HiMap >>= \ hi_files -> --- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files]) - newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> + -- Otherwise, just carry on + Just (export_env, rn_env, explicit_names) -> - fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> - let - rec_occ_fn :: Name -> [RdrName] - rec_occ_fn n = case lookupUFM rec_occ_fm n of - Nothing -> [] - Just (rn,occs) -> occs + -- RENAME THE SOURCE + initRnMS rn_env mod_name SourceMode ( + addImplicits mod_name `thenRn_` + mapRn rnDecl local_decls + ) `thenRn` \ rn_local_decls -> - global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn) - in - getGlobalNames iface_cache global_name_info us1 input >>= - \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) -> + -- SLURP IN ALL THE NEEDED DECLARATIONS + slurpDecls rn_local_decls `thenRn` \ rn_all_decls -> - if not (isEmptyBag top_errs) then - return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic) - else - -- No top-level name errors so rename source ... - case initRn True mod occ_env us2 - (rnSource imp_mods unqual_imps imp_fixes input) of { - ((rn_module, export_fn, src_occs), src_errs, src_warns) -> + -- GENERATE THE VERSION/USAGE INFO + getImportVersions mod_name exports `thenRn` \ import_versions -> + getNameSupplyRn `thenRn` \ name_supply -> - --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $ + -- REPORT UNUSED NAMES + reportUnusedNames explicit_names `thenRn_` + -- GENERATE THE SPECIAL-INSTANCE MODULE LIST + -- The "special instance" modules are those modules that contain instance + -- declarations that contain no type constructor or class that was declared + -- in that module. + getSpecialInstModules `thenRn` \ imported_special_inst_mods -> let - occ_fm :: UniqFM (RnName, [RdrName]) - - occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs] - occ_fm = addListToUFM_C insert_occ emptyUFM occ_list - - insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds) - - insert new [] = [new] - insert new xxs@(x:xs) = case cmp new x of LT_ -> new : xxs - EQ_ -> xxs - GT__ -> x : insert new xs - - occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm)) - multiple_occs (rn, (o1:o2:_)) = True - multiple_occs _ = False + special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls, + all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty)) + ] + special_inst_mods | null special_inst_decls = imported_special_inst_mods + | otherwise = mod_name : imported_special_inst_mods in - return (rn_module, imp_mods, - top_errs `unionBags` src_errs, - top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, - occ_fm, export_fn) - - }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> - - if not (isEmptyBag errs_so_far) then - return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) - else - - -- No errors renaming source so rename the interfaces ... + + + -- RETURN THE RENAMED MODULE let - -- split up all names that occurred in the source; between - -- those that are defined therein and those merely mentioned. - -- We also divide by tycon/class and value names (as usual). - - occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ] - -- all occurrence names, from this module and imported + import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] - (defined_here, defined_elsewhere) - = partition isLocallyDefined occ_rns - - (_, imports_used) - = partition isRnWired defined_elsewhere - - (def_tcs, def_vals) = partition isRnTyConOrClass defined_here - (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns - -- the occ stuff includes *all* occurrences, - -- including those for which we have definitions - - (orig_def_env, orig_def_dups) - = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals) - (map pair_orig def_tcs) - (orig_occ_env, orig_occ_dups) - = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals) - (map pair_orig occ_tcs) - - pair_orig rn = (origName rn, rn) - - -- we must ensure that the definitions of things in the BuiltinKey - -- table which may be *required* by the typechecker etc are read. - - must_haves - = [ name_fn (mkBuiltinName u pRELUDE str) - | (str, (u, name_fn)) <- fmToList b_keys, - str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] + renamed_module = HsModule mod_name vers + trashed_exports trashed_imports trashed_fixities + rn_all_decls + loc in - ASSERT (isEmptyBag orig_occ_dups) - ASSERT (isEmptyBag orig_def_dups) - - rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env - rn_module (must_haves ++ imports_used) >>= - \ (rn_module_with_imports, final_env, - (implicit_val_fm, implicit_tc_fm), - usage_stuff, - (iface_errs, iface_warns)) -> - - return (rn_module_with_imports, - final_env, - imp_mods, - usage_stuff, - errs_so_far `unionBags` iface_errs, - warns_so_far `unionBags` iface_warns) + rnStats rn_all_decls `thenRn_` + returnRn (Just (renamed_module, + (import_versions, export_env, special_inst_mods), + name_supply, + import_mods)) + } where - rn_panic = panic "renameModule: aborted with errors" - - (us1, us') = splitUniqSupply us - (us2, us3) = splitUniqSupply us' + trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing + trashed_imports = {-trace "rnSource:trashed_imports"-} [] + trashed_fixities = [] \end{code} -\begin{code} -makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath) - -makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)" -makeHiMap (Just f) - = readFile f >>= \ cts -> - return (snag_mod emptyFM cts []) - where - -- we alternate between "snag"ging mod(ule names) and path(names), - -- accumulating names (reversed) and the final resulting map - -- as we move along. - - snag_mod map [] [] = map - snag_mod map (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs [] - snag_mod map (c:cs) rmod = snag_mod map cs (c:rmod) - - snag_path map mod [] rpath = addToFM map mod (reverse rpath) - snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs [] - snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath) -\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} -{- TESTING: -pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) - = ppAboves [ - ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v, - case mv of { Nothing -> ppNil; Just n -> ppInt n }], - - ppPStr SLIT("__versions__"), - ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ], - - ppPStr SLIT("__exports__"), - ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn, - case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}] - | (n,(rn,ex)) <- fmToList exm ], - - pp_ims (bagToList ims), - pp_fixities lfx, - pp_decls ltdm lvdm, - pp_insts (bagToList lids), - pp_pragmas ldp - ] +addImplicits mod_name + = addImplicitOccsRn (implicit_main ++ default_tys) where - pp_ims [] = ppNil - pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__")) - (ppCat (map ppPStr ms)) - - pp_fixities fx - | isEmptyFM fx = ppNil - | otherwise = ppAboves (ppPStr SLIT("__fixities__") - : [ ppr PprDebug fix | (n, fix) <- fmToList fx]) + -- 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.] + 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 = [] +\end{code} - pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__") - : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds]) - pp_insts [] = ppNil - pp_insts is = ppAboves (ppPStr SLIT("__instances__") - : [ pprRdrInstDecl i | i <- is]) +\begin{code} +slurpDecls decls + = -- First of all, get all the compulsory decls + slurp_compulsories decls `thenRn` \ decls1 -> - pp_pragmas ps | isEmptyFM ps = ppNil - | otherwise = panic "Rename.pp_pragmas" + -- Next get the optional ones + closeDecls Optional decls1 `thenRn` \ decls2 -> -pprRdrIfaceDecl (TypeSig tc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl] + -- Finally get those deferred data type declarations + getDeferredDataDecls `thenRn` \ data_decls -> + mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls -> -pprRdrIfaceDecl (NewTypeSig tc dc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, - ppStr "; ", ppr PprDebug decl] + -- Done + returnRn (rn_data_decls ++ decls2) -pprRdrIfaceDecl (DataSig tc dcs dfs _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, - ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl] + where + -- 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 decls `thenRn` \ decls1 -> + + -- 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 inst_decls `thenRn` \ new_inst_decls -> + slurp_compulsories (new_inst_decls ++ decls1) +\end{code} -pprRdrIfaceDecl (ClassSig c ops _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, - ppStr "; ", ppr PprDebug decl] +\begin{code} +closeDecls :: Necessity + -> [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 -> + case maybe_unresolved of + + -- No more unresolved names + Nothing -> returnRn decls + + -- An unresolved name + Just name + -> -- Slurp its declaration, if any +-- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_` + importDecl name necessity `thenRn` \ maybe_decl -> + case maybe_decl of + + -- No declaration... (wired in thing or optional) + Nothing -> closeDecls necessity decls + + -- Found a declaration... rename it + Just decl -> rn_iface_decl mod_name necessity decl `thenRn` \ new_decl -> + closeDecls necessity (new_decl : decls) + where + mod_name = nameModule name + + +rn_iface_decl mod_name necessity decl -- Notice that the rnEnv starts empty + = initRnMS emptyRnEnv mod_name (InterfaceMode necessity) (rnDecl 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 +\end{code} -pprRdrIfaceDecl (ValSig f _ ty) - = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty] +\begin{code} +reportUnusedNames explicit_avail_names + | not opt_D_show_unused_imports + = returnRn () -pprRdrInstDecl (InstSig c t _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ", - ppr PprDebug decl] --} + | 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))] + in + (if null imported_unused + then returnRn () + else addWarnRn pp_imp) `thenRn_` + + (if null local_unused + then returnRn () + else addWarnRn pp_local) + +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} +