X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=2d8bd929457f7bee2a8ece74f39250a122c3c956;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=409abef3c9f3e2407da158b2faa11791c2c29fcd;hpb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 409abef..2d8bd92 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,45 +8,50 @@ module Rename ( renameModule ) where -import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO ) -import Ubiq +IMP_Ubiq() +IMPORT_1_3(List(partition)) import HsSyn import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) -import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired ) +import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, SYN_IE(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 Maybes +--import Name +--import Outputable +--import RnIfaces +--import PprStyle +--import Pretty +--import FiniteMap +--import Util (pprPanic, pprTrace) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), UsagesMap(..), VersionsMap(..) ) import RnMonad -import RnNames ( getGlobalNames, GlobalNameInfo(..) ) +import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) ) import RnSource ( rnSource ) -import RnIfaces ( rnIfaces ) -import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) +import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache ) +import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv ) import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiMap ) -import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) +import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) +import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) ) -import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( pRELUDE ) +import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName, + origName, + Name, RdrName(..), ExportFlag(..) + ) +--import PprStyle -- ToDo:rm +import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) +import Pretty import Unique ( ixClassKey ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) -import Util ( panic, assertPanic ) +import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) \end{code} \begin{code} @@ -57,6 +62,10 @@ renameModule :: UniqSupply RnEnv, -- final env (for renaming derivings) [Module], -- imported modules; for profiling + (Name -> ExportFlag, -- export info + ([(Name,ExportFlag)], + [(Name,ExportFlag)])), + (UsagesMap, VersionsMap, -- version info; for usage [Module]), -- instance modules; for iface @@ -69,29 +78,31 @@ ToDo: May want to arrange to return old interface for this module! ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} -renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) +renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) - = let - (b_names, b_keys, _) = builtinNameInfo + = {- + let + pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n] 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)) - -- ]}) $ - + pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) -> + ppAboves [ ppCat (map pp_pair (keysFM builtin_ids)) + , ppCat (map pp_pair (keysFM builtin_tcs)) + , ppCat (map pp_pair (keysFM builtinKeysMap)) + ]}) $ + -} + -- _scc_ "rnGlobalNames" 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 -> + initIfaceCache modname hi_files >>= \ iface_cache -> - fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> + 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 - global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn) + global_name_info = (builtinNameMaps, builtinKeysMap, 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) -> @@ -101,12 +112,12 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) else -- No top-level name errors so rename source ... - case initRn True mod occ_env us2 + -- _scc_ "rnSource" + case initRn True modname occ_env us2 (rnSource imp_mods unqual_imps imp_fixes input) of { - ((rn_module, export_fn, src_occs), src_errs, src_warns) -> + ((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) -> --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $ - let occ_fm :: UniqFM (RnName, [RdrName]) @@ -121,21 +132,25 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) GT__ -> x : insert new xs occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm)) - multiple_occs (rn, (o1:o2:_)) = True + + multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate") + -- the user is rarely responsible if + -- "negate" is mentioned in multiple ways multiple_occs _ = False in return (rn_module, imp_mods, top_errs `unionBags` src_errs, top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, - occ_fm, export_fn) + occ_fm, (export_fn, module_dotdots)) - }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> + }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) -> if not (isEmptyBag errs_so_far) then - return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) + return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) else -- No errors renaming source so rename the interfaces ... + -- _scc_ "preRnIfaces" let -- split up all names that occurred in the source; between -- those that are defined therein and those merely mentioned. @@ -156,26 +171,34 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) -- 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) + = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals) + (map pairify_rn 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) - - must_haves - = [ name_fn (mkBuiltinName u mod str) - | ((str, mod), (u, name_fn)) <- fmToList b_keys, - str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] + = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals) + (map pairify_rn occ_tcs) + + -- This stuff is pretty dodgy right now: I think original + -- names and occurrence names may be getting entangled + -- when they shouldn't be... WDP 96/06 + + pairify_rn rn -- ToDo: move to Name? + = let + name = getName rn + in + (if isLocalName name + then Unqual (getLocalName name) + else case (origName "pairify_rn" name) of { OrigName m n -> + Qual m n } + , rn) in -- ASSERT (isEmptyBag orig_occ_dups) - (if (isEmptyBag orig_occ_dups) then \x->x - else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $ +-- (if (isEmptyBag orig_occ_dups) then \x->x +-- else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $ ASSERT (isEmptyBag orig_def_dups) + -- _scc_ "rnIfaces" rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env - rn_module (must_haves ++ imports_used) >>= + rn_module (initMustHaves ++ imports_used) >>= \ (rn_module_with_imports, final_env, (implicit_val_fm, implicit_tc_fm), usage_stuff, @@ -184,6 +207,7 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) return (rn_module_with_imports, final_env, imp_mods, + export_stuff, usage_stuff, errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns) @@ -192,6 +216,17 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) (us1, us') = splitUniqSupply us (us2, us3) = splitUniqSupply us' + +initMustHaves :: [RnName] + -- things we *must* find declarations for, because the + -- compiler may eventually make reference to them (e.g., + -- class Eq) +initMustHaves + | opt_NoImplicitPrelude + = [{-no Prelude.hi, no point looking-}] + | otherwise + = [ name_fn (mkWiredInName u orig ExportAll) + | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ] \end{code} \begin{code} @@ -215,67 +250,9 @@ makeHiMap (Just f) snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath) \end{code} +Warning message used herein: \begin{code} -{- TESTING: -pprPIface (ParsedIface m ms 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 - ] - 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]) - - 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]) - - pp_pragmas ps | isEmptyFM ps = ppNil - | otherwise = panic "Rename.pp_pragmas" - -pprRdrIfaceDecl (TypeSig tc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (NewTypeSig tc dc _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, - ppStr "; ", ppr PprDebug decl] - -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] - -pprRdrIfaceDecl (ClassSig c ops _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, - ppStr "; ", ppr PprDebug decl] - -pprRdrIfaceDecl (ValSig f _ ty) - = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty] - -pprRdrInstDecl (InstSig c t _ decl) - = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ", - ppr PprDebug decl] --} +multipleOccWarn (name, occs) sty + = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", + ppInterleave ppComma (map (ppr sty) occs)] \end{code}