X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnIfaces.lhs;h=72fb264f358b48f1579bb163ad0a5bc57de6d032;hb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;hp=01dc045d25923058e8798dd67540c6ce69b1d287;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 01dc045..72fb264 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,14 +7,12 @@ #include "HsVersions.h" module RnIfaces ( - findHiFiles, +-- findHiFiles, cachedIface, cachedDecl, readIface, rnIfaces, - finalIfaceInfo, - IfaceCache(..), - VersionInfo(..) + IfaceCache(..) ) where import Ubiq @@ -31,20 +29,23 @@ import RnMonad import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) import ParseIface ( parseIface ) -import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) ) +import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), + VersionsMap(..), UsagesMap(..) + ) -import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) -import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) +import Bag ( emptyBag, unitBag, consBag, snocBag, + unionBags, unionManyBags, isEmptyBag, bagToList ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, - fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} ) -import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, isRdrLexCon, - RdrName(..){-instance NamedThing-} + fmToList, delListFromFM, sizeFM, foldFM, unitFM, + plusFM_C, keysFM{-ToDo:rm-} ) +import Maybes ( maybeToBool ) +import Name ( moduleNamePair, origName, RdrName(..) ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) +import PrelMods ( pRELUDE ) import Pretty import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) @@ -58,8 +59,11 @@ type ModuleToIfaceContents = FiniteMap Module ParsedIface type ModuleToIfaceFilePath = FiniteMap Module FilePath type IfaceCache - = MutableVar _RealWorld (ModuleToIfaceContents, - ModuleToIfaceFilePath) + = MutableVar _RealWorld + (ModuleToIfaceContents, -- interfaces for individual interface files + ModuleToIfaceContents, -- merged interfaces based on module name + -- used for extracting info about original names + ModuleToIfaceFilePath) \end{code} ********************************************************* @@ -71,12 +75,13 @@ type IfaceCache Return a mapping from module-name to absolute-filename-for-that-interface. \begin{code} +{- OLD: findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) findHiFiles dirs sysdirs - = hPutStr stderr " findHiFiles " >> + = --hPutStr stderr " findHiFiles " >> do_dirs emptyFM (dirs ++ sysdirs) >>= \ result -> - hPutStr stderr " done\n" >> + --hPutStr stderr " done\n" >> return result where do_dirs env [] = return env @@ -85,7 +90,7 @@ findHiFiles dirs sysdirs do_dirs new_env dirs ------- do_dir env dir - = hPutStr stderr "D" >> + = --hPutStr stderr "D" >> getDirectoryContents dir >>= \ entries -> do_entries env entries where @@ -97,7 +102,7 @@ findHiFiles dirs sysdirs do_entry env e = case (acceptable_hi (reverse e)) of Nothing -> --trace ("Deemed uncool:"++e) $ - hPutStr stderr "." >> + --hPutStr stderr "." >> return env Just mod -> let @@ -105,12 +110,12 @@ findHiFiles dirs sysdirs in case (lookupFM env pmod) of Nothing -> --trace ("Adding "++mod++" -> "++e) $ - hPutStr stderr "!" >> + --hPutStr stderr "!" >> return (addToFM env pmod (dir ++ '/':e)) -- ToDo: use DIR_SEP, not / Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $ - hPutStr stderr "." >> + --hPutStr stderr "." >> return env ------- acceptable_hi rev_e -- looking at pathname *backwards* @@ -132,6 +137,7 @@ findHiFiles dirs sysdirs else Just cand where is_modname_char c = isAlphanum c || c == '_' +-} \end{code} ********************************************************* @@ -144,16 +150,35 @@ Return cached info about a Module's interface; otherwise, read the interface (using our @ModuleToIfaceFilePath@ map to decide where to look). +Note: we have two notions of interface + * the interface for a particular file name + * the (combined) interface for a particular module name + +The idea is that two source files may declare a module +with the same name with the declarations being merged. + +This allows us to have file PreludeList.hs producing +PreludeList.hi but defining part of module Prelude. +When PreludeList is imported its contents will be +added to Prelude. In this way all the original names +for a particular module will be available the imported +decls are renamed. + +ToDo: Check duplicate definitons are the same. +ToDo: Check/Merge duplicate pragmas. + + \begin{code} -cachedIface :: IfaceCache +cachedIface :: Bool -- True => want merged interface for original name + -> IfaceCache -- False => want file interface only -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface iface_cache mod - = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) -> +cachedIface want_orig_iface iface_cache mod + = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> case (lookupFM iface_fm mod) of - Just iface -> return (Succeeded iface) + Just iface -> return (want_iface iface orig_fm) Nothing -> case (lookupFM file_fm mod) of Nothing -> return (Failed (noIfaceErr mod)) @@ -165,9 +190,52 @@ cachedIface iface_cache mod Succeeded iface -> let iface_fm' = addToFM iface_fm mod iface + orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface in - writeVar iface_cache (iface_fm', file_fm) `seqPrimIO` - return (Succeeded iface) + writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO` + return (want_iface iface orig_fm') + where + want_iface iface orig_fm + | want_orig_iface + = case lookupFM orig_fm mod of + Nothing -> Failed (noOrigIfaceErr mod) + Just orig_iface -> Succeeded orig_iface + | otherwise + = Succeeded iface + + iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod + +---------- +mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1) + (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2) + = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)), + ppStr "merged with", ppPStr mod1]) $ + ASSERT(mod1 == mod2) + ParsedIface mod1 + (True, unionBags files2 files1) + (panic "mergeIface: module version numbers") + (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from + (panic "mergeIface: usage version numbers") -- the merged file interfaces named above + (panic "mergeIface: decl version numbers") + (panic "mergeIface: exports") + (panic "mergeIface: instance modules") + (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2) + (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2) + (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2) + (unionBags idefs1 idefs2) + (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2) + where + dup_merge str ppr_dup dup1 dup2 + = pprTrace "mergeIfaces:" + (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl", + ppr_dup dup1, ppr_dup dup2]) $ + dup2 + + idecl_nm (TypeSig n _ _) = n + idecl_nm (NewTypeSig n _ _ _) = n + idecl_nm (DataSig n _ _ _ _) = n + idecl_nm (ClassSig n _ _ _) = n + idecl_nm (ValSig n _ _) = n ---------- cachedDecl :: IfaceCache @@ -175,14 +243,11 @@ cachedDecl :: IfaceCache -> RdrName -> IO (MaybeErr RdrIfaceDecl Error) --- ToDo: this is where the check for Prelude.map being --- located in PreludeList.map should be done ... - cachedDecl iface_cache class_or_tycon orig - = cachedIface iface_cache mod >>= \ maybe_iface -> + = cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (Failed err) - Succeeded (ParsedIface _ _ _ _ exps _ _ tdefs vdefs _ _) -> + Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of Just decl -> return (Succeeded decl) Nothing -> return (Failed (noDeclInIfaceErr mod str)) @@ -250,14 +315,21 @@ readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error) readIface file mod - = hPutStr stderr (" reading "++file) >> + = --hPutStr stderr (" reading "++file) >> readFile file `thenPrimIO` \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> hPutStr stderr " parsing" >> + Right contents -> --hPutStr stderr " parsing" >> let parsed = parseIface contents in - hPutStr stderr " done\n" >> - return parsed + --hPutStr stderr " done\n" >> + return ( + case parsed of + Failed _ -> parsed + Succeeded p -> Succeeded (init_merge mod p) + ) + where + init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags) + = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags \end{code} @@ -275,6 +347,7 @@ rnIfaces :: IfaceCache -- iface cache (mutvar) -> IO (RenamedHsModule, -- extended module RnEnv, -- final env (for renaming derivings) ImplicitEnv, -- implicit names used (for usage info) + (UsagesMap,VersionsMap,[Module]), -- usage info (Bag Error, Bag Warning)) rnIfaces iface_cache imp_mods us @@ -287,14 +360,14 @@ rnIfaces iface_cache imp_mods us = {- pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ - pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $ + pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ - pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $ + pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ - pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $ + pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $ pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $ - pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $ + pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $ pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $ -} @@ -306,6 +379,11 @@ rnIfaces iface_cache imp_mods us if_errs_warns), if_final_env) -> + -- finalize what we want to say we learned about the + -- things we used + finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>= + \ usage_stuff@(usage_info, version_info, instance_mods) -> + return (HsModule modname iface_version exports imports fixities (typedecls ++ if_typedecls) typesigs @@ -316,6 +394,7 @@ rnIfaces iface_cache imp_mods us src_loc, if_final_env, if_implicits, + usage_stuff, if_errs_warns) where decls_and_insts todo def_env occ_env to_return us @@ -379,19 +458,26 @@ rnIfaces iface_cache imp_mods us -- pprTrace "do_decls:done:" (ppr PprDebug n) $ do_decls ns down to_return - Nothing -> -- OK, see what the cache has for us... + Nothing + | fst (moduleNamePair n) == modname -> + -- avoid looking in interface for the module being compiled + -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $ + do_decls ns down (add_err (thisModImplicitErr modname n) to_return) - cachedDeclByType iface_cache n >>= \ maybe_ans -> - case maybe_ans of - Failed err -> -- add the error, but keep going: - -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ - do_decls ns down (add_err err to_return) + | otherwise -> + -- OK, see what the cache has for us... - Succeeded iface_decl -> -- something needing renaming! - let + cachedDeclByType iface_cache n >>= \ maybe_ans -> + case maybe_ans of + Failed err -> -- add the error, but keep going: + -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + do_decls ns down (add_err err to_return) + + Succeeded iface_decl -> -- something needing renaming! + let (us1, us2) = splitUniqSupply (uniqsupply down) - in - case (initRn False{-iface-} modname (occenv down) us1 ( + in + case (initRn False{-iface-} modname (occenv down) us1 ( setExtraRn emptyUFM{-no fixities-} $ rnIfaceDecl iface_decl)) of { ((if_decl, if_defd, if_implicits), if_errs, if_warns) -> @@ -412,7 +498,7 @@ rnIfaces iface_cache imp_mods us add_implicits if_implicits $ add_errs if_errs $ add_warns if_warns to_return) - } + } ----------- type Go_Down = (RnEnv, -- stuff we already have defns for; @@ -567,19 +653,19 @@ sub (val_ment, tc_ment) (val_defds, tc_defds) \begin{code} cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) cacheInstModules iface_cache imp_mods - = readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) -> let imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ] (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces))) - get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims + get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims in - accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces -> + accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces -> -- Sanity Check: -- Assert that instance modules given by direct imports contains -- instance modules extracted from all visited modules - readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) -> + readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) -> let all_ifaces = eltsFM all_iface_fm (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) @@ -615,9 +701,9 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return = -- all the instance decls we might even want to consider -- are in the ParsedIfaces that are in our cache - readVar iface_cache `thenPrimIO` \ (iface_fm, _) -> + readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) -> let - all_ifaces = eltsFM iface_fm + all_ifaces = eltsFM orig_iface_fm all_insts = unionManyBags (map get_insts all_ifaces) interesting_insts = filter want_inst (bagToList all_insts) @@ -651,7 +737,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)) } where - get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts + get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts add_done_inst (InstSig clas tycon _ _) inst_env = addToFM_C (+) inst_env (tycon,clas) 1 @@ -674,12 +760,10 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return = case lookupTcRnEnv occ_env nm of Just _ -> True Nothing -> -- maybe it's builtin - case nm of - Qual _ _ -> False - Unqual n -> - case (lookupFM b_tc_names n) of + let str_mod = case nm of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_tc_names str_mod) of Just _ -> True - Nothing -> maybeToBool (lookupFM b_keys n) + Nothing -> maybeToBool (lookupFM b_keys str_mod) (b_tc_names, b_keys) -- pretty UGLY ... = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys) @@ -700,22 +784,69 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl \begin{code} finalIfaceInfo :: IfaceCache -- iface cache - -> [RnName] -- all imported names required - -> [Module] -- directly imported modules - -> IO (VersionInfo, -- info about version numbers + -> Module -- this module's name + -> RnEnv + -> [RenamedInstDecl] +-- -> [RnName] -- all imported names required +-- -> [Module] -- directly imported modules + -> IO (UsagesMap, + VersionsMap, -- info about version numbers [Module]) -- special instance modules -type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])] +finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls + = +-- pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ +-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ +-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ +-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ + let + val_stuff@(val_usages, val_versions) + = foldFM process_item (emptyFM, emptyFM){-init-} qual -finalIfaceInfo iface_cache imps_reqd imp_mods - = return ([], []) + (all_usages, all_versions) + = foldFM process_item val_stuff{-keep going-} tc_qual + in + return (all_usages, all_versions, []) + where + process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components + -> (UsagesMap, VersionsMap) -- input + -> (UsagesMap, VersionsMap) -- output + + process_item (n,m) rn as_before@(usages, versions) + | irrelevant rn + = as_before + | m == modname -- this module => add to "versions" + = (usages, addToFM versions n 1{-stub-}) + | otherwise -- from another module => add to "usages" + = (add_to_usages usages m n 1{-stub-}, versions) + + irrelevant (RnConstr _ _) = True -- We don't report these in their + irrelevant (RnField _ _) = True -- own right in usages/etc. + irrelevant (RnClassOp _ _) = True + irrelevant _ = False + + add_to_usages usages m n version + = addToFM usages m ( + case (lookupFM usages m) of + Nothing -> -- nothing for this module yet... + (1{-stub-}, unitFM n version) + + Just (mversion, mstuff) -> -- the "new" stuff will shadow the old + (mversion, addToFM mstuff n version) + ) \end{code} \begin{code} +thisModImplicitErr mod n sty + = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod] + noIfaceErr mod sty = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] +noOrigIfaceErr mod sty + = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod] + noDeclInIfaceErr mod str sty = ppBesides [ppPStr SLIT("Could not find interface declaration of: "), ppPStr mod, ppStr ".", ppPStr str]