X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnIfaces.lhs;h=396f021ab0947e49aacd87d7975f3e1c9bf31c36;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=965ab3f922d79cb4eeb2f961b474aa5f9c752538;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 965ab3f..396f021 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -15,7 +15,15 @@ module RnIfaces ( IMP_Ubiq() -import PreludeGlaST ( thenPrimIO, seqPrimIO, newVar, 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 ) @@ -35,42 +43,45 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, fmToList, delListFromFM, sizeFM, foldFM, unitFM, - plusFM_C, addListToFM, keysFM{-ToDo:rm-} + plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap ) -import Maybes ( maybeToBool ) +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, SYN_IE(BuiltinNames) ) +--import PprStyle -- ToDo:rm +--import Outputable -- ToDo:rm +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, - panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) + panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} ) \end{code} \begin{code} type ModuleToIfaceContents = FiniteMap Module ParsedIface type ModuleToIfaceFilePath = FiniteMap Module FilePath +#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 _RealWorld + (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) `thenPrimIO` \ iface_var -> - return (IfaceCache mod b_names iface_var) - where - b_names = case builtinNameInfo of (b_names,_,_) -> b_names + = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var -> + return (IfaceCache mod builtinNameMaps iface_var) \end{code} ********************************************************* @@ -110,7 +121,7 @@ cachedIface :: IfaceCache -> IO (MaybeErr ParsedIface Error) cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname - = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> + = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) -> case (lookupFM iface_fm modname) of Just iface -> return (want_iface iface orig_fm) @@ -127,7 +138,7 @@ cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname iface_fm' = addToFM iface_fm modname iface orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface in - writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO` + writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ -> return (want_iface iface orig_fm') where want_iface iface orig_fm @@ -143,8 +154,8 @@ cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname ---------- 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]) $ + = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)), + -- ppStr "merged with", ppPStr mod1]) $ ASSERT(mod1 == mod2) ParsedIface mod1 (True, unionBags files2 files1) @@ -154,16 +165,16 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs (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) + (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) + (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]) $ + 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 @@ -233,7 +244,7 @@ cachedDeclByType iface_cache rn case rn of WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn) - RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn) + RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn) RnSyn _ -> return_maybe_decl RnData _ _ _ -> return_maybe_decl @@ -274,7 +285,7 @@ readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error readIface file modname item = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >> - readFile file `thenPrimIO` \ read_result -> + TRY_IO (readFile file) >>= \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) Right contents -> --hPutStr stderr ".." >> @@ -429,7 +440,7 @@ rnIfaces iface_cache imp_mods us cachedDeclByType iface_cache n >>= \ maybe_ans -> case maybe_ans of CachingAvoided _ -> - pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $ + --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $ do_decls ns down to_return CachingFail err -> -- add the error, but keep going: @@ -490,7 +501,7 @@ 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) -> - (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList 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 de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] @@ -540,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 @@ -621,7 +632,7 @@ sub (val_ment, tc_ment) (val_defds, tc_defds) cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods - = readVar iface_var `thenPrimIO` \ (iface_fm, _, _) -> + = 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))) @@ -634,7 +645,7 @@ cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods -- Assert that instance modules given by direct imports contains -- instance modules extracted from all visited modules - readVar iface_var `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)))) @@ -670,7 +681,7 @@ rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_ = -- all the instance decls we might even want to consider -- are in the ParsedIfaces that are in our cache - readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) -> + readVar iface_var ST_THEN \ (_, orig_iface_fm, _) -> let all_ifaces = eltsFM orig_iface_fm all_insts = concat (map get_insts all_ifaces) @@ -736,23 +747,13 @@ rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_ Just _ -> True Nothing -> -- maybe it's builtin let orig = qualToOrigName nm in - case (lookupFM b_tc_names orig) of + case (lookupFM builtinTcNamesMap orig) of Just _ -> True - Nothing -> maybeToBool (lookupFM b_keys orig) - - (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] --} + Nothing -> maybeToBool (lookupFM builtinKeysMap orig) \end{code} \begin{code} -rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes _RealWorld RenamedInstDecl +rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod) \end{code} @@ -778,7 +779,7 @@ finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qua -- 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))) $ - readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) -> + readVar iface_var ST_THEN \ (_, orig_iface_fm, _) -> let all_ifaces = eltsFM orig_iface_fm -- all the interfaces we have looked at @@ -864,7 +865,7 @@ 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]