X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=2d8bd929457f7bee2a8ece74f39250a122c3c956;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=e116f7e6966d2b4a855a733e5498937421e0b58d;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index e116f7e..2d8bd92 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,85 +8,116 @@ module Rename ( renameModule ) where -import PreludeGlaST ( thenPrimIO, returnPrimIO, fixPrimIO, newVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO ) -import Ubiq +IMP_Ubiq() +IMPORT_1_3(List(partition)) import HsSyn import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) -import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass ) +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 ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), + UsagesMap(..), VersionsMap(..) + ) import RnMonad -import RnNames ( getGlobalNames, GlobalNameInfo(..) ) +import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) ) import RnSource ( rnSource ) -import RnIfaces ( rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface ) -import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) -import MainMonad - -import Bag ( isEmptyBag, unionBags, bagToList, listToBag ) -import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( emptyFM, eltsFM ) -import Name ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) ) -import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) +import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache ) +import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv ) + +import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) +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, 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 ) - -findHiFiles :: PrimIO (FiniteMap Module FAST_STRING) -findHiFiles = returnPrimIO emptyFM +import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) \end{code} \begin{code} -renameModule :: BuiltinNames - -> BuiltinKeys - -> UniqSupply +renameModule :: UniqSupply -> RdrNameHsModule - -> MainIO - ( - RenamedHsModule, -- output, after renaming - [Module], -- imported modules; for profiling + -> IO (RenamedHsModule, -- output, after renaming + RnEnv, -- final env (for renaming derivings) + [Module], -- imported modules; for profiling - VersionInfo, -- version info; for usage - [Module], -- instance modules; for iface + (Name -> ExportFlag, -- export info + ([(Name,ExportFlag)], + [(Name,ExportFlag)])), - Bag Error, - Bag Warning - ) -\end{code} + (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: Return OrigName RnEnv to rename derivings etc with. -ToDo: Builtin names which must be read. ToDo: Deal with instances (instance version, this module on instance list ???) \begin{code} -renameModule b_names b_keys us - input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) - = findHiFiles `thenPrimIO` \ hi_files -> - newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var -> +renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) + + = {- + let + pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n] + in + 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]) + initIfaceCache modname hi_files >>= \ iface_cache -> - fixPrimIO ( \ ~(_, _, _, _, 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_var global_name_info us1 input - `thenPrimIO` \ (occ_env, imp_mods, imp_fixes, top_errs, top_warns) -> + getGlobalNames iface_cache global_name_info us1 input >>= + \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) -> if not (isEmptyBag top_errs) then - returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic) + 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 imp_fixes input) of { - ((rn_module, export_fn, src_occs), src_errs, src_warns) -> + -- _scc_ "rnSource" + case initRn True modname occ_env us2 + (rnSource imp_mods unqual_imps imp_fixes input) of { + ((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]) @@ -101,51 +132,127 @@ renameModule b_names b_keys us 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 - returnPrimIO (rn_module, imp_mods, - top_errs `unionBags` src_errs, - top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, - occ_fm, export_fn) + return (rn_module, imp_mods, + top_errs `unionBags` src_errs, + top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, + occ_fm, (export_fn, module_dotdots)) - }) `thenPrimIO` \ (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 - returnMn (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 - imports_used = [ rn | (rn,_) <- eltsUFM occ_fm, not (isLocallyDefined rn) ] - (import_tcs, import_vals) = partition (\ rn -> isRnTyCon rn || isRnClass rn) imports_used + -- 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). - (orig_env, orig_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig import_vals) - (map pair_orig import_tcs) - pair_orig rn = (getOrigNameRdr rn, rn) + occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ] + -- all occurrence names, from this module and imported - -- ToDo: Do we need top-level names from this module in orig_env ??? - in - ASSERT (isEmptyBag orig_dups) - rnInterfaces iface_var orig_env us3 rn_module imports_used - `thenPrimIO` \ (rn_module_with_imports, - (implicit_val_fm, implicit_tc_fm), - iface_errs, iface_warns) -> - let - all_imports_used = imports_used ++ eltsFM implicit_tc_fm ++ eltsFM implicit_val_fm + (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 pairify_rn def_vals) + (map pairify_rn def_tcs) + (orig_occ_env, orig_occ_dups) + = 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 - finalIfaceInfo iface_var all_imports_used imp_mods - `thenPrimIO` \ (version_info, instance_mods) -> +-- 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])) $ + ASSERT (isEmptyBag orig_def_dups) - returnMn (rn_module_with_imports, imp_mods, - version_info, instance_mods, - errs_so_far `unionBags` iface_errs, - warns_so_far `unionBags` iface_warns) + -- _scc_ "rnIfaces" + rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env + rn_module (initMustHaves ++ 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, + export_stuff, + usage_stuff, + errs_so_far `unionBags` iface_errs, + warns_so_far `unionBags` iface_warns) where rn_panic = panic "renameModule: aborted with errors" (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} +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} + +Warning message used herein: +\begin{code} +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}