X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRename.lhs;h=409abef3c9f3e2407da158b2faa11791c2c29fcd;hb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;hp=8fcc75e98d70946b50898d004d82d81f2654d555;hpb=1ffb620ae1457b2e3eb5e415a999a4f6f15fec45;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 8fcc75e..409abef 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -14,7 +14,7 @@ import Ubiq import HsSyn import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) -import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired ) +import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired ) --ToDo:rm: all for debugging only import Maybes @@ -26,60 +26,63 @@ import Pretty import FiniteMap import Util (pprPanic, pprTrace) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), + UsagesMap(..), VersionsMap(..) + ) import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) -import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) ) -import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) -import MainMonad +import RnIfaces ( rnIfaces ) +import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList ) +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 ( BuiltinNames(..), BuiltinKeys(..) ) +import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) import PrelMods ( pRELUDE ) +import Unique ( ixClassKey ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) import Util ( panic, assertPanic ) \end{code} \begin{code} -renameModule :: BuiltinNames - -> BuiltinKeys - -> UniqSupply +renameModule :: UniqSupply -> RdrNameHsModule -> 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 + (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 _ _ _ _ _ _ _ _ _ _) +renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) - = 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)) - ]}) $ + = 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)) + -- ]}) $ - findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> - newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> + 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 -> fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> let @@ -121,7 +124,7 @@ renameModule b_names b_keys us multiple_occs (rn, (o1:o2:_)) = True multiple_occs _ = False in - return (rn_module, imp_mods, + return (rn_module, imp_mods, top_errs `unionBags` src_errs, top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, occ_fm, export_fn) @@ -139,17 +142,18 @@ renameModule b_names b_keys us -- 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 + -- all occurrence names, from this module and imported (defined_here, defined_elsewhere) = partition isLocallyDefined occ_rns - (_, imports_used) = partition isRnWired defined_elsewhere + (_, 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 + -- 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) @@ -160,32 +164,29 @@ renameModule b_names b_keys us pair_orig rn = (origName rn, rn) - must_haves -- everything in the BuiltinKey table; as we *may* need these - -- later, we'd better bring their definitions in - = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ] - where - mk_key_name str name_fn u - = -- this is emphatically *not* the Right Way to do this... (WDP 96/04) - if (str == SLIT("main") || str == SLIT("mainPrimIO")) then - Nothing - else - Just (name_fn (mkBuiltinName u pRELUDE str)) + must_haves + = [ name_fn (mkBuiltinName u mod str) + | ((str, mod), (u, name_fn)) <- fmToList b_keys, + str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] in - ASSERT (isEmptyBag orig_occ_dups) +-- 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) - rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>= - \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) -> - let - all_imports_used = bagToList (unionManyBags [listToBag imports_used, - listToBag (eltsFM implicit_tc_fm), - listToBag (eltsFM implicit_val_fm)]) - in - finalIfaceInfo iface_cache all_imports_used imp_mods >>= - \ (version_info, instance_mods) -> - - return (rn_module_with_imports, imp_mods, version_info, instance_mods, - errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns) + 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) where rn_panic = panic "renameModule: aborted with errors" @@ -194,7 +195,29 @@ renameModule b_names b_keys us \end{code} \begin{code} -pprPIface (ParsedIface m v mv lcm exm ims lfx ltdm lvdm lids ldp) +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} + +\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 }], @@ -237,13 +260,16 @@ 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] + = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, + ppStr "; ", ppr PprDebug decl] -pprRdrIfaceDecl (DataSig tc dcs _ decl) - = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, 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] + = 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] @@ -251,4 +277,5 @@ pprRdrIfaceDecl (ValSig f _ ty) pprRdrInstDecl (InstSig c t _ decl) = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ", ppr PprDebug decl] +-} \end{code}