From: simonmar Date: Thu, 1 Mar 2001 14:26:01 +0000 (+0000) Subject: [project @ 2001-03-01 14:26:00 by simonmar] X-Git-Tag: Approximately_9120_patches~2507 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=18b24e64d6a9e3011a2437cec87ef09ad3e6f900;p=ghc-hetmet.git [project @ 2001-03-01 14:26:00 by simonmar] GHCi fixes: - expressions are now compiled in a pseudo-module "$Interactive", which avoids some problems with storage of demand-loaded declarations. - compilation manager now detects when it needs to read the interace for a module, even if it is already compiled. GHCi never demand-loads interfaces now. - (from Simon PJ) fix a problem with the recompilation checker, which meant that modules were sometimes not recompiled when they should have been. - ByteCodeGen/Link: move linker related stuff into ByteCodeLink. --- diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index de14adf..54cb751 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -20,6 +20,7 @@ module CmLink ( Linkable(..), Unlinked(..), import Interpreter import DriverPipeline +import ByteCodeLink ( linkIModules, linkIExpr ) import CmTypes import CmStaticInfo ( GhciMode(..) ) import Outputable ( SDoc ) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 8d711b2..4b41fe5 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -50,8 +50,7 @@ import VarEnv ( emptyTidyEnv ) import HscTypes import HscMain ( initPersistentCompilerState ) import Finder -import UniqFM ( lookupUFM, addToUFM, delListFromUFM, - UniqFM, listToUFM ) +import UniqFM import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) import DriverFlags ( getDynFlags ) @@ -233,7 +232,7 @@ cmTypeOfExpr cmstate dflags expr case names of [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name return (new_cmstate, maybe_tystr) - _other -> pprPanic "cmTypeOfExpr" (ppr names) + _other -> return (new_cmstate, Nothing) #endif ----------------------------------------------------------------------------- @@ -347,9 +346,6 @@ cmLoadModule cmstate1 rootname let ghci_mode = gmode cmstate1 -- this never changes -- Do the downsweep to reestablish the module graph - -- then generate version 2's by retaining in HIT,HST,UI a - -- stable set S of modules, as defined below. - dflags <- getDynFlags let verb = verbosity dflags @@ -387,8 +383,8 @@ cmLoadModule cmstate1 rootname -- 1. All home imports of ms are either in ms or S -- 2. A valid linkable exists for each module in ms - stable_mods - <- preUpsweep valid_linkables mg2unsorted_names [] mg2_with_srcimps + stable_mods <- preUpsweep valid_linkables hit1 + mg2unsorted_names [] mg2_with_srcimps let stable_summaries = concatMap (findInSummaries mg2unsorted) stable_mods @@ -585,10 +581,6 @@ getValidLinkable :: [Linkable] -> Bool -> [Linkable] -> ModSummary getValidLinkable old_linkables objects_allowed new_linkables summary = do let mod_name = name_of_summary summary - -- we only look for objects on disk the first time around; - -- if the user compiles a module on the side during a GHCi session, - -- it won't be picked up until the next ":load". This is what the - -- "null old_linkables" test below is. maybe_disk_linkable <- if (not objects_allowed) then return Nothing @@ -612,6 +604,10 @@ getValidLinkable old_linkables objects_allowed new_linkables summary Nothing -> False Just l_disk -> linkableTime l == linkableTime l_disk + -- we only look for objects on disk the first time around; + -- if the user compiles a module on the side during a GHCi session, + -- it won't be picked up until the next ":load". This is what the + -- "null old_linkables" test below is. linkable | null old_linkables = maybeToList maybe_disk_linkable | otherwise = maybeToList maybe_old_linkable @@ -647,14 +643,20 @@ maybe_getFileLinkable mod_name obj_fn -- Do a pre-upsweep without use of "compile", to establish a -- (downward-closed) set of stable modules for which we won't call compile. +-- a stable module: +-- * has a valid linkable (see getValidLinkables above) +-- * depends only on stable modules +-- * has an interface in the HIT (interactive mode only) + preUpsweep :: [Linkable] -- new valid linkables + -> HomeIfaceTable -> [ModuleName] -- names of all mods encountered in downsweep -> [ModuleName] -- accumulating stable modules -> [SCC ModSummary] -- scc-ified mod graph, including src imps -> IO [ModuleName] -- stable modules -preUpsweep valid_lis all_home_mods stable [] = return stable -preUpsweep valid_lis all_home_mods stable (scc0:sccs) +preUpsweep valid_lis hit all_home_mods stable [] = return stable +preUpsweep valid_lis hit all_home_mods stable (scc0:sccs) = do let scc = flattenSCC scc0 scc_allhomeimps :: [ModuleName] scc_allhomeimps @@ -672,14 +674,15 @@ preUpsweep valid_lis all_home_mods stable (scc0:sccs) = isJust (findModuleLinkable_maybe valid_lis modname) where modname = name_of_summary new_summary + has_interface summary = ms_mod summary `elemUFM` hit + scc_is_stable = all_imports_in_scc_or_stable && all has_valid_linkable scc + && all has_interface scc if scc_is_stable - then preUpsweep valid_lis all_home_mods (scc_names++stable) sccs - else preUpsweep valid_lis all_home_mods stable sccs - - where + then preUpsweep valid_lis hit all_home_mods (scc_names++stable) sccs + else preUpsweep valid_lis hit all_home_mods stable sccs -- Helper for preUpsweep. Assuming that new_summary's imports are all diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index cea9dbb..3962210 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -6,8 +6,7 @@ \begin{code} module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, filterNameMap, - byteCodeGen, coreExprToBCOs, - linkIModules, linkIExpr + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" @@ -44,7 +43,7 @@ import PprType ( pprType ) import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) import ByteCodeItbls ( ItblEnv, mkITbls ) import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap, + ClosureEnv, HValue, filterNameMap, iNTERP_STACK_CHECK_THRESH ) import List ( intersperse, sortBy ) @@ -122,27 +121,6 @@ coreExprToBCOs dflags expr root_bco <- assembleBCO root_proto_bco return (root_bco, auxiliary_bcos) - - --- Linking stuff -linkIModules :: ItblEnv -- incoming global itbl env; returned updated - -> ClosureEnv -- incoming global closure env; returned updated - -> [([UnlinkedBCO], ItblEnv)] - -> IO ([HValue], ItblEnv, ClosureEnv) -linkIModules gie gce mods - = do let (bcoss, ies) = unzip mods - bcos = concat bcoss - final_gie = foldr plusFM gie ies - (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos - return (linked_bcos, final_gie, final_gce) - - -linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr - -> IO HValue -- IO BCO# really -linkIExpr ie ce (root_ul_bco, aux_ul_bcos) - = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos - (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco] - return root_bco \end{code} %************************************************************************ diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 1619758..2e5287d 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -5,7 +5,8 @@ \begin{code} module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap, + ClosureEnv, HValue, filterNameMap, + linkIModules, linkIExpr, iNTERP_STACK_CHECK_THRESH ) where @@ -38,6 +39,7 @@ import MArray ( castSTUArray, newAddrArray, writeAddrArray ) import Foreign ( Word16, Ptr(..) ) import Addr ( Word, Addr, nullAddr ) +import FiniteMap import PrelBase ( Int(..) ) import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, @@ -56,6 +58,25 @@ import PrelIOBase ( IO(..) ) %************************************************************************ \begin{code} +-- Linking stuff +linkIModules :: ItblEnv -- incoming global itbl env; returned updated + -> ClosureEnv -- incoming global closure env; returned updated + -> [([UnlinkedBCO], ItblEnv)] + -> IO ([HValue], ItblEnv, ClosureEnv) +linkIModules gie gce mods + = do let (bcoss, ies) = unzip mods + bcos = concat bcoss + final_gie = foldr plusFM gie ies + (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos + return (linked_bcos, final_gie, final_gce) + + +linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr + -> IO HValue -- IO BCO# really +linkIExpr ie ce (root_ul_bco, aux_ul_bcos) + = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos + (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco] + return root_bco -- Link a bunch of BCOs and return them + updated closure env. linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env @@ -74,7 +95,10 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos ce_top_additions = filter (isGlobalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions else ce_all_additions - ce_out = addListToFM ce_in ce_additions + ce_out = -- make sure we're not inserting duplicate names into the + -- closure environment, which leads to trouble. + ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions)) + addListToFM ce_in ce_additions return (ce_out, hvals) where -- A lazier zip, in which no demand is propagated to the second diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 28a788b..29de2ac 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -31,7 +31,7 @@ import SrcLoc ( mkSrcLoc ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) -import PrelNames ( vanillaSyntaxMap, knownKeyNames ) +import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) import TcModule @@ -452,9 +452,9 @@ A naked expression returns a singleton Name [it]. hscStmt dflags hst hit pcs0 icontext stmt = let InteractiveContext { - ic_rn_env = rn_env, + ic_rn_env = rn_env, ic_type_env = type_env, - ic_module = this_mod } = icontext + ic_module = scope_mod } = icontext in do { maybe_stmt <- hscParseStmt dflags stmt ; case maybe_stmt of @@ -463,20 +463,23 @@ hscStmt dflags hst hit pcs0 icontext stmt -- Rename it (pcs1, print_unqual, maybe_renamed_stmt) - <- renameStmt dflags hit hst pcs0 this_mod rn_env parsed_stmt + <- renameStmt dflags hit hst pcs0 scope_mod + iNTERACTIVE rn_env parsed_stmt + ; case maybe_renamed_stmt of Nothing -> return (pcs0, Nothing) Just (bound_names, rn_stmt) -> do { -- Typecheck it - maybe_tc_return <- typecheckStmt dflags pcs1 hst type_env - print_unqual this_mod bound_names rn_stmt + maybe_tc_return + <- typecheckStmt dflags pcs1 hst type_env + print_unqual iNTERACTIVE bound_names rn_stmt ; case maybe_tc_return of { Nothing -> return (pcs0, Nothing) ; Just (pcs2, tc_expr, bound_ids) -> do { -- Desugar it - ds_expr <- deSugarExpr dflags pcs2 hst this_mod print_unqual tc_expr + ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr -- Simplify it ; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index f52f2cd..ec70d32 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -18,7 +18,7 @@ module HscTypes ( IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - VersionInfo(..), initialVersionInfo, + VersionInfo(..), initialVersionInfo, lookupVersion, TyThing(..), isTyClThing, implicitTyThingIds, @@ -74,7 +74,7 @@ import CoreSyn ( IdCoreRule ) import FiniteMap ( FiniteMap ) import Bag ( Bag ) -import Maybes ( seqMaybe ) +import Maybes ( seqMaybe, orElse ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp, sortLt ) @@ -339,13 +339,19 @@ data VersionInfo -- The version of an Id changes if its fixity changes -- Ditto data constructors, class operations, except that the version of -- the parent class/tycon changes + -- + -- If a name isn't in the map, it means 'initialVersion' } initialVersionInfo :: VersionInfo initialVersionInfo = VersionInfo { vers_module = initialVersion, vers_exports = initialVersion, vers_rules = initialVersion, - vers_decls = emptyNameEnv } + vers_decls = emptyNameEnv + } + +lookupVersion :: NameEnv Version -> Name -> Version +lookupVersion env name = lookupNameEnv env name `orElse` initialVersion data Deprecations = NoDeprecs | DeprecAll DeprecTxt -- Whole module deprecated diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a77ce51..4720cb0 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -6,7 +6,7 @@ \begin{code} module MkIface ( mkModDetails, mkModDetailsFromIface, completeIface, - writeIface, pprIface + writeIface, pprIface, pprUsage ) where #include "HsVersions.h" @@ -25,7 +25,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), TyThing(..), DFunId, TypeEnv, Avails, WhatsImported(..), GenAvailInfo(..), ImportVersion, AvailInfo, Deprecations(..), - extendTypeEnvList + extendTypeEnvList, lookupVersion, ) import CmdLineOpts @@ -54,6 +54,7 @@ import Type ( splitSigmaTy, tidyTopType, deNoteType ) import SrcLoc ( noSrcLoc ) import Outputable import Module ( ModuleName ) +import Maybes ( orElse ) import IO ( IOMode(..), openFile, hClose ) \end{code} @@ -381,7 +382,8 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, where final_iface = new_iface { mi_version = new_version } - new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version), + old_mod_vers = vers_module old_version + new_version = VersionInfo { vers_module = bumpVersion no_output_change old_mod_vers, vers_exports = bumpVersion no_export_change (vers_exports old_version), vers_rules = bumpVersion no_rule_change (vers_rules old_version), vers_decls = tc_vers } @@ -396,8 +398,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, -- Fill in the version number on the new declarations by looking at the old declarations. -- Set the flag if anything changes. -- Assumes that the decls are sorted by hsDeclName. - old_vers_decls = vers_decls old_version - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities + (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_version old_fixities new_fixities (dcl_tycl old_decls) (dcl_tycl new_decls) pp_diffs = vcat [pp_tc_diffs, pp_change no_export_change "Export list", @@ -407,14 +408,15 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, pp_change True what = empty pp_change False what = text what <+> ptext SLIT("changed") -diffDecls :: NameEnv Version -- Old version map +diffDecls :: VersionInfo -- Old version -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls -> (Bool, -- True <=> no change SDoc, -- Record of differences - NameEnv Version) -- New version + NameEnv Version) -- New version map -diffDecls old_vers old_fixities new_fixities old new +diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers }) + old_fixities new_fixities old new = diff True empty emptyNameEnv old new where -- When seeing if two decls are the same, @@ -423,19 +425,26 @@ diffDecls old_vers old_fixities new_fixities old new same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) - diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] - diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds + diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] + diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new [] nds + where + new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers) + -- When adding a new item, start from the old module version + -- This way, if you have version 4 of f, then delete f, then add f again, + -- you'll get version 6 of f, which will (correctly) force recompilation of + -- clients + diff ok_so_far pp new_vers (od:ods) (nd:nds) = case od_name `compare` nd_name of LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds) GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds - EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds - | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds + EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds + | otherwise -> diff False (pp $$ changed od nd) new_vers_with_diff ods nds where od_name = tyClDeclName od nd_name = tyClDeclName nd - new_vers' = extendNameEnv new_vers nd_name - (bumpVersion False (lookupNameEnv_NF old_vers od_name)) + new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version) + old_version = lookupVersion old_decls_vers od_name only_old d = ptext SLIT("Only in old iface:") <+> ppr d only_new d = ptext SLIT("Only in new iface:") <+> ppr d diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 8e6a7d7..1972ae2 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -30,6 +30,7 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs, ) +import MkIface ( pprUsage ) import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, @@ -97,7 +98,8 @@ renameModule dflags hit hst pcs this_module rdr_module renameStmt :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module -- current context (module) + -> Module -- current context (scope to compile in) + -> Module -- current module -> LocalRdrEnv -- current context (temp bindings) -> RdrNameStmt -- parsed stmt -> IO ( PersistentCompilerState, @@ -105,13 +107,13 @@ renameStmt :: DynFlags Maybe ([Name], (SyntaxMap, RenamedStmt, [RenamedHsDecl])) ) -renameStmt dflags hit hst pcs this_module local_env stmt +renameStmt dflags hit hst pcs scope_module this_module local_env stmt = renameSource dflags hit hst pcs this_module $ -- Load the interface for the context module, so -- that we can get its top-level lexical environment -- Bale out if we fail to do this - loadInterface doc (moduleName this_module) ImportByUser `thenRn` \ iface -> + loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface -> let rdr_env = mi_globals iface print_unqual = unQualInScope rdr_env in @@ -245,6 +247,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec -- GENERATE THE VERSION/USAGE INFO mkImportInfo mod_name imports `thenRn` \ my_usages -> + traceHiDiffsRn (vcat (map pprUsage my_usages)) `thenRn_` -- BUILD THE MODULE INTERFACE let diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 3666e0b..e72c059 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -38,8 +38,7 @@ import Id ( idType ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocalName, isHomePackageName, - NamedThing(..) + nameModule, isLocalName, NamedThing(..) ) import Name ( elemNameEnv, delFromNameEnv ) import Module ( Module, ModuleEnv, @@ -169,8 +168,7 @@ mkImportInfo this_mod imports -- The sort is to put them into canonical order mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns, - let v = lookupNameEnv version_env n `orElse` - pprPanic "mk_whats_imported" (ppr n) + let v = lookupVersion version_env n ] where lt_occ n1 n2 = nameOccName n1 < nameOccName n2 @@ -302,22 +300,26 @@ rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ dec \begin{code} -recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), - iSlurp = slurped_names, - iVSlurp = (imp_mods, imp_names) }) +recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), + iSlurp = slurped_names, + iVSlurp = vslurp }) avail = ASSERT2( not (isLocalName (availName avail)), ppr avail ) - ifaces { iDecls = (decls_map', n_slurped+1), + ifaces { iDecls = (new_decls_map, n_slurped+1), iSlurp = new_slurped_names, - iVSlurp = new_vslurp } + iVSlurp = updateVSlurp vslurp (availName avail) } where - decls_map' = foldl delFromNameEnv decls_map (availNames avail) - main_name = availName avail + new_decls_map = foldl delFromNameEnv decls_map (availNames avail) new_slurped_names = addAvailToNameSet slurped_names avail - new_vslurp | isHomePackageName main_name = (imp_mods, addOneToNameSet imp_names main_name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) - mod = nameModule main_name +recordVSlurp ifaces name = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) name } + +updateVSlurp (imp_mods, imp_names) main_name + | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name) + | otherwise = (extendModuleSet imp_mods mod, imp_names) + where + mod = nameModule main_name + recordLocalSlurps new_names = getIfacesRn `thenRn` \ ifaces -> setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names }) @@ -569,17 +571,25 @@ importDecl name returnRn AlreadySlurped else + -- STEP 2: Check if it's already in the type environment getTypeEnvRn `thenRn` \ lookup -> case lookup name of { - Just ty_thing | name `elemNameEnv` wiredInThingEnv - -> -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - loadHomeInterface wi_doc name `thenRn_` - returnRn (InTypeEnv ty_thing) - - | otherwise - -> returnRn (InTypeEnv ty_thing) ; + Just ty_thing + | name `elemNameEnv` wiredInThingEnv + -> -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + loadHomeInterface wi_doc name `thenRn_` + returnRn (InTypeEnv ty_thing) + + | otherwise + -> -- Record that we use this thing. We must do this + -- regardless of whether we need to demand-slurp it in + -- or we already have it in the type environment. Why? + -- because the slurp information is used to generate usage + -- information in the interface. + setIfacesRn (recordVSlurp ifaces (getName ty_thing)) `thenRn_` + returnRn (InTypeEnv ty_thing) ; Nothing -> @@ -594,13 +604,11 @@ importDecl name (decls_map, _) = iDecls ifaces in case lookupNameEnv decls_map name of - Just (avail,_,decl) - -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` - returnRn (HereItIs decl) + Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_` + returnRn (HereItIs decl) - Nothing - -> addErrRn (getDeclErr name) `thenRn_` - returnRn AlreadySlurped + Nothing -> addErrRn (getDeclErr name) `thenRn_` + returnRn AlreadySlurped } where wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name @@ -670,6 +678,7 @@ checkModUsage (mod_name, _, is_boot, whats_imported) from | is_boot = ImportByUserSource | otherwise = ImportByUser in + traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_` tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) -> case maybe_err of { @@ -739,7 +748,7 @@ checkEntityUsage new_vers (name,old_vers) out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) Just new_vers -- It's there, but is it up to date? - | new_vers == old_vers -> returnRn upToDate + | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_` returnRn upToDate | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 56f7e0d..ed05fb9 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -55,7 +55,7 @@ import Type ( funResultTy, splitForAllTys, liftedTypeKind, mkTyConApp, tidyType ) import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) import Id ( Id, idType, idName, isLocalId, idUnfolding ) -import Module ( Module, isHomeModule, moduleName ) +import Module ( Module, moduleName ) import Name ( Name, toRdrName, isGlobalName ) import Name ( nameEnvElts, lookupNameEnv ) import TyCon ( tyConGenInfo ) @@ -482,11 +482,8 @@ tcImports unf_env pcs hst get_fixity this_mod decls -- (on the GHCi command line, for example). In this case, we -- want to treat everything we pulled in as an imported thing. imported_things - | isHomeModule this_mod - = filter (not . isLocalThing this_mod) all_things - | otherwise - = all_things - + = filter (not . isLocalThing this_mod) all_things + new_pte :: PackageTypeEnv new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things