X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnIfaces.lhs;h=f805e312e9b6cb720dec3bc3615a400db068992e;hb=573ef10b2afd99d3c6a36370a9367609716c97d2;hp=d2f62e42734e7e1c120f9da6656120c126e3b308;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d2f62e4..f805e31 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,18 +7,23 @@ #include "HsVersions.h" module RnIfaces ( - findHiFiles, cachedIface, - cachedDecl, - readIface, + cachedDecl, CachingResult(..), rnIfaces, - IfaceCache(..) + IfaceCache, initIfaceCache ) where -import Ubiq +IMP_Ubiq() -import LibDirectory -import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) ) +#if __GLASGOW_HASKELL__ >= 200 +# define ST_THEN `stThen` +# define TRY_IO tryIO +IMPORT_1_3(GHCio(stThen,tryIO)) +#else +# define ST_THEN `thenPrimIO` +# define TRY_IO try +#endif import HsSyn import HsPragmas ( noGenPragmas ) @@ -27,27 +32,26 @@ import RnHsSyn import RnMonad import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) -import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) +import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) import ParseIface ( parseIface ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), VersionsMap(..), UsagesMap(..) ) -import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) -import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) -import ErrUtils ( Error(..), Warning(..) ) +import Bag ( emptyBag, unitBag, consBag, snocBag, + unionBags, unionManyBags, isEmptyBag, bagToList ) +import ErrUtils ( SYN_IE(Error), SYN_IE(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, addListToFM, keysFM{-ToDo:rm-}, FiniteMap ) +import Maybes ( maybeToBool, MaybeErr(..) ) +import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..), + isLexCon, RdrName(..), Name{-instance NamedThing-} ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm -import PrelInfo ( builtinNameInfo ) +import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) ) import Pretty -import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) import UniqSupply ( splitUniqSupply ) import Util ( sortLt, removeDups, cmpPString, startsWith, @@ -58,81 +62,26 @@ import Util ( sortLt, removeDups, cmpPString, startsWith, type ModuleToIfaceContents = FiniteMap Module ParsedIface type ModuleToIfaceFilePath = FiniteMap Module FilePath -type IfaceCache - = MutableVar _RealWorld (ModuleToIfaceContents, - ModuleToIfaceFilePath) -\end{code} - -********************************************************* -* * -\subsection{Looking for interface files} -* * -********************************************************* - -Return a mapping from module-name to -absolute-filename-for-that-interface. -\begin{code} -findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) - -findHiFiles dirs sysdirs - = hPutStr stderr " findHiFiles " >> - do_dirs emptyFM (dirs ++ sysdirs) >>= \ result -> - hPutStr stderr " done\n" >> - return result - where - do_dirs env [] = return env - do_dirs env (dir:dirs) - = do_dir env dir >>= \ new_env -> - do_dirs new_env dirs - ------- - do_dir env dir - = hPutStr stderr "D" >> - getDirectoryContents dir >>= \ entries -> - do_entries env entries - where - do_entries env [] = return env - do_entries env (e:es) - = do_entry env e >>= \ new_env -> - do_entries new_env es - ------- - do_entry env e - = case (acceptable_hi (reverse e)) of - Nothing -> --trace ("Deemed uncool:"++e) $ - hPutStr stderr "." >> - return env - Just mod -> - let - pmod = _PK_ mod - in - case (lookupFM env pmod) of - Nothing -> --trace ("Adding "++mod++" -> "++e) $ - 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 "." >> - return env - ------- - acceptable_hi rev_e -- looking at pathname *backwards* - = case (startsWith (reverse opt_HiSuffix) rev_e) of - Nothing -> Nothing - Just xs -> plausible_modname xs{-reversed-} - - ------- - de_dot ('.' : '/' : xs) = xs - de_dot xs = xs - - ------- - plausible_modname rev_e - = let - cand = reverse (takeWhile is_modname_char rev_e) - in - if null cand || not (isUpper (head cand)) - then Nothing - else Just cand - where - is_modname_char c = isAlphanum c || c == '_' +#if __GLASGOW_HASKELL__ >= 200 +# define REAL_WORLD RealWorld +#else +# define REAL_WORLD _RealWorld +#endif + +data IfaceCache + = IfaceCache + Module -- the name of the module being compiled + BuiltinNames -- so we can avoid going after things + -- the compiler already knows about + (MutableVar REAL_WORLD + (ModuleToIfaceContents, -- interfaces for individual interface files + ModuleToIfaceContents, -- merged interfaces based on module name + -- used for extracting info about original names + ModuleToIfaceFilePath)) + +initIfaceCache mod hi_files + = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var -> + return (IfaceCache mod builtinNameMaps iface_var) \end{code} ********************************************************* @@ -145,68 +94,153 @@ 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 + -> Bool -- True => want merged interface for original name + -- False => want file interface only + -> FAST_STRING -- item that prompted search (debugging only!) -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface iface_cache mod - = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) -> +cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname + = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) -> - case (lookupFM iface_fm mod) of - Just iface -> return (Succeeded iface) + case (lookupFM iface_fm modname) of + Just iface -> return (want_iface iface orig_fm) Nothing -> - case (lookupFM file_fm mod) of - Nothing -> return (Failed (noIfaceErr mod)) + case (lookupFM file_fm modname) of + Nothing -> return (Failed (noIfaceErr modname)) Just file -> - readIface file mod >>= \ read_iface -> + readIface file modname item >>= \ read_iface -> case read_iface of Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $ return (Failed err) Succeeded iface -> let - iface_fm' = addToFM iface_fm mod iface + iface_fm' = addToFM iface_fm modname 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_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ -> + return (want_iface iface orig_fm') + where + want_iface iface orig_fm + | want_orig_iface + = case lookupFM orig_fm modname of + Nothing -> Failed (noOrigIfaceErr modname) + 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 ---------- +data CachingResult + = CachingFail Error -- tried to find a decl, something went wrong + | CachingHit RdrIfaceDecl -- got it + | CachingAvoided (Maybe (Either RnName RnName)) + -- didn't look in the interface + -- file(s); Nothing => the thing + -- *should* be in the source module; + -- Just (Left ...) => builtin val name; + -- Just (Right ..) => builtin tc name + cachedDecl :: IfaceCache -> Bool -- True <=> tycon or class name - -> 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 -> - case maybe_iface of - Failed err -> return (Failed err) - 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)) - where - (mod, str) = moduleNamePair orig + -> OrigName + -> IO CachingResult + +cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _) + class_or_tycon name@(OrigName mod str) + + = -- pprTrace "cachedDecl:" (ppr PprDebug name) $ + if mod == this_mod then -- some i/face has made a reference + return (CachingAvoided Nothing) -- to something from this module + else + let + b_env = if class_or_tycon then b_tc_names else b_val_names + in + case (lookupFM b_env name) of + Just rn -> -- in builtins! + return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn))) + + Nothing -> + cachedIface iface_cache True str mod >>= \ maybe_iface -> + case maybe_iface of + Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $ + return (CachingFail err) + Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> + case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of + Just decl -> return (CachingHit decl) + Nothing -> return (CachingFail (noDeclInIfaceErr mod str)) ---------- cachedDeclByType :: IfaceCache -> RnName{-NB: diff type than cachedDecl -} - -> IO (MaybeErr RdrIfaceDecl Error) + -> IO CachingResult cachedDeclByType iface_cache rn -- the idea is: check that, e.g., if we're given an -- RnClass, then we really get back a ClassDecl from -- the cache (not an RnData, or something silly) - = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl -> + = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl -> let return_maybe_decl = return maybe_decl - return_failed msg = return (Failed msg) + return_failed msg = return (CachingFail msg) in case maybe_decl of - Failed _ -> return_maybe_decl - Succeeded if_decl -> + CachingAvoided _ -> return_maybe_decl + CachingFail io_msg -> return_failed (ifaceIoErr io_msg rn) + CachingHit if_decl -> case rn of WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn) @@ -247,18 +281,24 @@ cachedDeclByType iface_cache rn \end{code} \begin{code} -readIface :: FilePath -> Module - -> IO (MaybeErr ParsedIface Error) +readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error) -readIface file mod - = hPutStr stderr (" reading "++file) >> - readFile file `thenPrimIO` \ read_result -> +readIface file modname item + = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >> + TRY_IO (readFile file) >>= \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> hPutStr stderr " parsing" >> + Right contents -> --hPutStr stderr ".." >> let parsed = parseIface contents in - hPutStr stderr " done\n" >> - return parsed + --hPutStr stderr "..\n" >> + return ( + case parsed of + Failed _ -> parsed + Succeeded p -> Succeeded (init_merge modname 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} @@ -288,7 +328,6 @@ rnIfaces iface_cache imp_mods us todo = {- pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ - 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] | (n,m) <- keysFM tc_qual]) $ @@ -310,7 +349,7 @@ rnIfaces iface_cache imp_mods us -- finalize what we want to say we learned about the -- things we used - finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>= + 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 @@ -327,7 +366,10 @@ rnIfaces iface_cache imp_mods us if_errs_warns) where decls_and_insts todo def_env occ_env to_return us - = do_decls todo -- initial batch of names to process + = let + (us1,us2) = splitUniqSupply us + in + do_decls todo -- initial batch of names to process (def_env, occ_env, us1) -- init stuff down to_return -- acc results >>= \ (decls_return, @@ -338,9 +380,8 @@ rnIfaces iface_cache imp_mods us do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM (add_errs errs decls_return) us2 - where - (us1,us2) = splitUniqSupply us + -------- do_insts def_env occ_env prev_env done_insts to_return us | size_tc_env occ_env == size_tc_env prev_env = return (to_return, occ_env) @@ -387,19 +428,30 @@ 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 + | moduleOf (origName "do_decls" 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_warn (thisModImplicitWarn 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 + CachingAvoided _ -> + pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $ + do_decls ns down to_return + + CachingFail err -> -- add the error, but keep going: + --pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + do_decls ns down (add_err err to_return) + + CachingHit 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) -> @@ -420,7 +472,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; @@ -437,10 +489,9 @@ type Go_Down = (RnEnv, -- stuff we already have defns for; ) lookup_defd (def_env, _, _) n - | isRnTyConOrClass n - = lookupTcRnEnv def_env (origName n) - | otherwise - = lookupRnEnv def_env (origName n) + = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env + (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s }) + -- this is hack because we are reusing the RnEnv technology defenv (def_env, _, _) = def_env occenv (_, occ_env, _) = occ_env @@ -450,10 +501,14 @@ new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us) add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) -> - ASSERT(isEmptyBag def_dups) + (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $ +-- ASSERT(isEmptyBag def_dups) let - val_occs = val_defds ++ fmToList val_imps - tc_occs = tc_defds ++ fmToList tc_imps + de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] + -- again, this hackery because we are reusing the RnEnv technology + + val_occs = val_defds ++ de_orig val_imps + tc_occs = tc_defds ++ de_orig tc_imps in case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) -> @@ -481,10 +536,11 @@ add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs) = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs) add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) - = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) + = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs) add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) +add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn)) add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws)) \end{code} @@ -495,7 +551,7 @@ data AddedDecl -- purely local | AddedSig RenamedSig rnIfaceDecl :: RdrIfaceDecl - -> RnM_Fixes _RealWorld + -> RnM_Fixes REAL_WORLD (AddedDecl, -- the resulting decl to add to the pot ([(RdrName,RnName)], [(RdrName,RnName)]), -- new val/tycon-class names that have @@ -564,8 +620,8 @@ rnIfaceDecl (ValSig f src_loc ty) sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv sub (val_ment, tc_ment) (val_defds, tc_defds) - = (delListFromFM val_ment (map fst val_defds), - delListFromFM tc_ment (map fst tc_defds)) + = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds), + delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds)) \end{code} % ------------------------------ @@ -574,20 +630,22 @@ 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, _) -> + +cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods + = readVar iface_var ST_THEN \ (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 -> + --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $ + accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) 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_var ST_THEN \ (all_iface_fm, _, _) -> let all_ifaces = eltsFM all_iface_fm (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) @@ -605,7 +663,7 @@ cacheInstModules iface_cache imp_mods @rnIfaceInstStuff@: Deal with instance declarations from interface files. \begin{code} -type InstanceEnv = FiniteMap (RdrName, RdrName) Int +type InstanceEnv = FiniteMap (OrigName, OrigName) Int rnIfaceInstStuff :: IfaceCache -- all about ifaces we've read @@ -619,21 +677,22 @@ rnIfaceInstStuff RnEnv, -- final occ env [RnName]) -- new unknown names -rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return +rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) 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_var ST_THEN \ (_, orig_iface_fm, _) -> let - all_ifaces = eltsFM iface_fm - all_insts = unionManyBags (map get_insts all_ifaces) - interesting_insts = filter want_inst (bagToList all_insts) + all_ifaces = eltsFM orig_iface_fm + all_insts = concat (map get_insts all_ifaces) + interesting_insts = filter want_inst all_insts -- Sanity Check: -- Assert that there are no more instances for the done instances - claim_done = filter is_done_inst (bagToList all_insts) + claim_done = filter is_done_inst all_insts claim_done_env = foldr add_done_inst emptyFM claim_done + has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v } in {- @@ -646,7 +705,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return case (initRn False{-iface-} modname occ_env us ( setExtraRn emptyUFM{-no fixities-} $ mapRn rnIfaceInst interesting_insts `thenRn` \ insts -> - getImplicitUpRn `thenRn` \ implicits -> + getImplicitUpRn `thenRn` \ implicits -> returnRn (insts, implicits))) of { ((if_insts, if_implicits), if_errs, if_warns) -> @@ -659,55 +718,53 @@ 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 imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts] - add_done_inst (InstSig clas tycon _ _) inst_env - = addToFM_C (+) inst_env (tycon,clas) 1 + tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon) - is_done_inst (InstSig clas tycon _ _) - = maybeToBool (lookupFM done_inst_env (tycon,clas)) + add_done_inst (_, InstSig clas tycon _ _) inst_env + = addToFM_C (+) inst_env (tycon_class clas tycon) 1 + + is_done_inst (_, InstSig clas tycon _ _) + = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon)) add_imp_occs (val_imps, tc_imps) occ_env - = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of + = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups) ext_occ_env + where + de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] + -- again, this hackery because we are reusing the RnEnv technology - want_inst i@(InstSig clas tycon _ _) + want_inst i@(imod, InstSig clas tycon _ _) = -- it's a "good instance" (one to hang onto) if we have a -- chance of referring to *both* the class and tycon later on ... - + --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $ mentionable tycon && mentionable clas && not (is_done_inst i) where mentionable nm = 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 - Just _ -> True - Nothing -> maybeToBool (lookupFM b_keys n) - - (b_tc_names, b_keys) -- pretty UGLY ... - = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys) - - ppr_insts insts - = ppAboves (map ppr_inst insts) - where - ppr_inst (InstSig c t _ inst_decl) - = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl] + let orig = qualToOrigName nm in + case (lookupFM builtinTcNamesMap orig) of + Just _ -> True + Nothing -> maybeToBool (lookupFM builtinKeysMap orig) \end{code} \begin{code} -rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl +rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl -rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl +rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod) \end{code} \begin{code} +type BigMaps = (FiniteMap Module Version, -- module-version map + FiniteMap (FAST_STRING,Module) Version) -- ordinary version map + finalIfaceInfo :: IfaceCache -- iface cache + -> Module -- this module's name -> RnEnv -> [RenamedInstDecl] -- -> [RnName] -- all imported names required @@ -716,21 +773,87 @@ finalIfaceInfo :: VersionsMap, -- info about version numbers [Module]) -- special instance modules -finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls +finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) 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: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_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ + readVar iface_var ST_THEN \ (_, orig_iface_fm, _) -> + let + all_ifaces = eltsFM orig_iface_fm + -- all the interfaces we have looked at + + big_maps + -- combine all the version maps we have seen into maps to + -- (a) lookup a module-version number, lookup an entity's + -- individual version number + = foldr mk_map (emptyFM,emptyFM) all_ifaces + + val_stuff@(val_usages, val_versions) + = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual + + (all_usages, all_versions) + = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual + in + return (all_usages, all_versions, []) + where + mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map) + = (addToFM mv_map m mv, -- add this module + addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ]) + + ----------------------- + process_item :: BigMaps + -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components + -> (UsagesMap, VersionsMap) -- input + -> (UsagesMap, VersionsMap) -- output + + process_item (big_mv_map, big_version_map) key@(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" + = case (add_to_usages usages key) of + Nothing -> as_before + Just new_usages -> (new_usages, versions) + where + add_to_usages usages key@(n,m) + = case (lookupFM big_mv_map m) of + Nothing -> Nothing + Just mv -> + case (lookupFM big_version_map key) of + Nothing -> Nothing + Just kv -> + Just $ addToFM usages m ( + case (lookupFM usages m) of + Nothing -> -- nothing for this module yet... + (mv, unitFM n kv) + + Just (mversion, mstuff) -> -- the "new" stuff will shadow the old + ASSERT(mversion == mv) + (mversion, addToFM mstuff n kv) + ) + + irrelevant (RnConstr _ _) = True -- We don't report these in their + irrelevant (RnField _ _) = True -- own right in usages/etc. + irrelevant (RnClassOp _ _) = True + irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr + irrelevant _ = False - return (emptyFM, emptyFM, []) \end{code} \begin{code} +thisModImplicitWarn mod n sty + = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")] + 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] @@ -742,5 +865,8 @@ ifaceLookupWiredErr msg n sty = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n] badIfaceLookupErr msg name decl sty - = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")] + = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"] + +ifaceIoErr io_msg rn sty + = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn] \end{code}