From: simonpj Date: Tue, 18 Jan 2005 12:19:12 +0000 (+0000) Subject: [project @ 2005-01-18 12:18:11 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1225 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ac80e0dececb68ed6385e3b34765fd8f9c019767;p=ghc-hetmet.git [project @ 2005-01-18 12:18:11 by simonpj] ------------------------ Reorganisation of hi-boot files ------------------------ The main point of this commit is to arrange that in the Compilation Manager's dependendency graph, hi-boot files are proper nodes. This is important to make sure that we compile everything in the right order. It's a step towards hs-boot files. * The fundamental change is that CompManager.ModSummary has a new field, ms_boot :: IsBootInterface I also tided up CompManager a bit. No change to the Basic Plan. ModSummary is now exported abstractly from CompManager (was concrete) * Hi-boot files now have import declarations. The idea is they are compulsory, so that the dependency analyser can find them * I changed an invariant: the Compilation Manager used to ensure that hscMain was given a HomePackageTable only for the modules 'below' the one being compiled. This was really only important for instances and rules, and it was a bit inconvenient. So I moved the filter to the compiler itself: see HscTypes.hptInstances and hptRules. * Module Packages.hs now defines data PackageIdH = HomePackage -- The "home" package is the package -- curently being compiled | ExtPackage PackageId -- An "external" package is any other package It was just a Maybe type before, so this makes it a bit clearer. * I tried to add a bit better location info to the IfM monad, so that errors in interfaces come with a slightly more helpful error message. See the if_loc field in TcRnTypes --- and follow-on consequences * Changed Either to Maybes.MaybeErr in a couple of places (more perspicuous) --- diff --git a/ghc/compiler/basicTypes/Module.hi-boot-6 b/ghc/compiler/basicTypes/Module.hi-boot-6 index 7677859..f2bd792 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-6 +++ b/ghc/compiler/basicTypes/Module.hi-boot-6 @@ -1,4 +1,4 @@ module Module where - +import GHC.Base data Module diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 4c93676..8743288 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -50,6 +50,7 @@ module Unique ( #include "HsVersions.h" import BasicTypes ( Boxity(..) ) +import PackageConfig ( PackageId, packageIdFS ) import FastString ( FastString, uniqueOfFS ) import Outputable import FastTypes @@ -158,6 +159,9 @@ x `hasKey` k = getUnique x == k instance Uniquable FastString where getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs)) +instance Uniquable PackageId where + getUnique pid = getUnique (packageIdFS pid) + instance Uniquable Int where getUnique i = mkUniqueGrimily i \end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 44c23ef..406c7a3 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -5,9 +5,10 @@ % \begin{code} module CompManager ( - ModuleGraph, ModSummary(..), + ModSummary, -- Abstract + ModuleGraph, -- All the modules from the home package - CmState, -- abstract + CmState, -- Abstract cmInit, -- :: GhciMode -> IO CmState @@ -27,6 +28,7 @@ module CompManager ( cmGetInfo, -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)]) GetInfoResult, cmBrowseModule, -- :: CmState -> IO [TyThing] + cmShowModule, CmRunResult(..), cmRunStmt, -- :: CmState -> String -> IO (CmState, CmRunResult) @@ -37,9 +39,7 @@ module CompManager ( HValue, cmCompileExpr, -- :: CmState -> String -> IO (CmState, Maybe HValue) - - cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) - + cmGetModuleGraph, -- :: CmState -> ModuleGraph cmSetDFlags, cmGetDFlags, @@ -51,7 +51,7 @@ where #include "HsVersions.h" -import Packages ( isHomeModule ) +import Packages ( isHomePackage ) import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) @@ -59,14 +59,12 @@ import DriverPhases import Finder import HscTypes import PrelNames ( gHC_PRIM ) -import Module ( Module, mkModule, - ModuleEnv, lookupModuleEnv, mkModuleEnv, - moduleEnvElts, extendModuleEnvList, extendModuleEnv, +import Module ( Module, mkModule, delModuleEnvList, mkModuleEnv, + lookupModuleEnv, moduleEnvElts, extendModuleEnv, moduleUserString, ModLocation(..) ) import GetImports import LoadIface ( noIfaceErr ) -import UniqFM import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) import SysTools ( cleanTempFilesExcept ) @@ -75,8 +73,9 @@ import StringBuffer ( hGetStringBuffer ) import Util import Outputable import Panic -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt_unset ) +import CmdLineOpts ( DynFlags(..) ) import Maybes ( expectJust, orElse, mapCatMaybes ) +import FiniteMap import DATA_IOREF ( readIORef ) @@ -85,6 +84,7 @@ import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType ) import TcRnDriver ( mkExportEnv, getModuleContents ) import IfaceSyn ( IfaceDecl ) import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) +import Module ( showModMsg ) import Name ( Name ) import NameEnv import Id ( idType ) @@ -96,6 +96,7 @@ import GHC.Exts ( unsafeCoerce# ) import Foreign import SrcLoc ( SrcLoc ) import Control.Exception as Exception ( Exception, try ) +import CmdLineOpts ( DynFlag(..), dopt_unset ) #endif import EXCEPTION ( throwDyn ) @@ -110,6 +111,83 @@ import Time ( ClockTime ) \end{code} +%************************************************************************ +%* * + The module dependency graph + ModSummary, ModGraph, NodeKey, NodeMap +%* * +%************************************************************************ + +The nodes of the module graph are + EITHER a regular Haskell source module + OR a hi-boot source module + +A ModuleGraph contains all the nodes from the home package (only). +There will be a node for each source module, plus a node for each hi-boot +module. + +\begin{code} +type ModuleGraph = [ModSummary] -- The module graph, + -- NOT NECESSARILY IN TOPOLOGICAL ORDER + +emptyMG :: ModuleGraph +emptyMG = [] + +-------------------- +data ModSummary + = ModSummary { + ms_mod :: Module, -- Name of the module + ms_boot :: IsBootInterface, -- Whether this is an hi-boot file + ms_location :: ModLocation, -- Location + ms_srcimps :: [Module], -- Source imports + ms_imps :: [Module], -- Non-source imports + ms_hs_date :: ClockTime -- Timestamp of summarised file + } + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +ms_allimps ms = ms_srcimps ms ++ ms_imps ms + +-------------------- +type NodeKey = (Module, IsBootInterface) -- The nodes of the graph are +type NodeMap a = FiniteMap NodeKey a -- keyed by (mod,boot) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_boot = boot }) = (mod,boot) + +emptyNodeMap :: NodeMap a +emptyNodeMap = emptyFM + +mkNodeMap :: [(NodeKey,a)] -> NodeMap a +mkNodeMap = listToFM + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = eltsFM +\end{code} + + +%************************************************************************ +%* * + The compilation manager state +%* * +%************************************************************************ + + \begin{code} -- Persistent state for the entire system data CmState @@ -120,7 +198,7 @@ data CmState } #ifdef GHCI -cmGetModInfo cmstate = (cm_mg cmstate, hsc_HPT (cm_hsc cmstate)) +cmGetModuleGraph cmstate = cm_mg cmstate cmGetBindings cmstate = nameEnvElts (ic_type_env (cm_ic cmstate)) cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate) cmHPT cmstate = hsc_HPT (cm_hsc cmstate) @@ -240,6 +318,19 @@ cmBrowseModule cmstate str exports_only ----------------------------------------------------------------------------- +cmShowModule :: CmState -> ModSummary -> String +cmShowModule cmstate mod_summary + = case lookupModuleEnv hpt mod of + Nothing -> panic "missing linkable" + Just mod_info -> showModMsg obj_linkable mod locn + where + obj_linkable = isObjectLinkable (hm_linkable mod_info) + where + hpt = hsc_HPT (cm_hsc cmstate) + mod = ms_mod mod_summary + locn = ms_location mod_summary + +----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. data CmRunResult @@ -449,7 +540,7 @@ cmDepAnal cmstate rootnames -- the system state at the same time. cmLoadModules :: CmState -- The HPT may not be as up to date - -> ModuleGraph -- Bang up to date + -> ModuleGraph -- Bang up to date; but may contain hi-boot no -> IO (CmState, -- new state SuccessFlag, -- was successful [String]) -- list of modules loaded @@ -474,17 +565,17 @@ cmLoadModules cmstate1 mg2unsorted let mg2unsorted_names = map ms_mod mg2unsorted - -- reachable_from follows source as well as normal imports - let reachable_from :: Module -> [Module] - reachable_from = downwards_closure_of_module mg2unsorted - - -- should be cycle free; ignores 'import source's - let mg2 = topological_sort False mg2unsorted - -- ... whereas this takes them into account. Used for + -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes + let mg2 :: [SCC ModSummary] + mg2 = topological_sort False mg2unsorted + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for -- backing out partially complete cycles following a failed -- upsweep, and for removing from hpt all the modules -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps = topological_sort True mg2unsorted + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topological_sort True mg2unsorted -- Sort out which linkables we wish to keep in the unlinked image. -- See getValidLinkables below for details. @@ -494,7 +585,7 @@ cmLoadModules cmstate1 mg2unsorted -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - let hpt2 = delListFromUFM hpt1 (map linkableModule new_linkables) + let hpt2 = delModuleEnvList hpt1 (map linkableModule new_linkables) hsc_env2 = hsc_env { hsc_HPT = hpt2 } -- When (verb >= 2) $ @@ -511,15 +602,13 @@ cmLoadModules cmstate1 mg2unsorted -- 1. All home imports of ms are either in ms or S -- 2. A valid old linkable exists for each module in ms - stable_mods <- preUpsweep valid_old_linkables - mg2unsorted_names [] mg2_with_srcimps - - let stable_summaries - = concatMap (findInSummaries mg2unsorted) stable_mods - - stable_linkables - = filter (\m -> linkableModule m `elem` stable_mods) - valid_old_linkables + -- mg2_with_srcimps has no hi-boot nodes, + -- and hence neither does stable_mods + stable_summaries <- preUpsweep valid_old_linkables + mg2unsorted_names [] mg2_with_srcimps + let stable_mods = map ms_mod stable_summaries + stable_linkables = filter (\m -> linkableModule m `elem` stable_mods) + valid_old_linkables when (verb >= 2) $ hPutStrLn stderr (showSDoc (text "Stable modules:" @@ -557,7 +646,7 @@ cmLoadModules cmstate1 mg2unsorted (ppFilesFromSummaries (flattenSCCs mg2)) (upsweep_ok, hsc_env3, modsUpswept) - <- upsweep_mods hsc_env2 valid_linkables reachable_from + <- upsweep_mods hsc_env2 valid_linkables cleanup upsweep_these -- At this point, modsUpswept and newLis should have the same @@ -688,10 +777,12 @@ getValidLinkables [Linkable] -- new linkables we just found ) -getValidLinkables mode old_linkables all_home_mods module_graph = do - ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods) - [] module_graph - return (partition_it ls [] []) +getValidLinkables mode old_linkables all_home_mods module_graph + = do { -- Process the SCCs in bottom-to-top order + -- (foldM works left-to-right) + ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods) + [] module_graph + ; return (partition_it ls [] []) } where partition_it [] valid new = (valid,new) partition_it ((l,b):ls) valid new @@ -699,6 +790,14 @@ getValidLinkables mode old_linkables all_home_mods module_graph = do | otherwise = partition_it ls (l:valid) new +getValidLinkablesSCC + :: GhciMode + -> [Linkable] -- old linkables + -> [Module] -- all home modules + -> [(Linkable,Bool)] + -> SCC ModSummary + -> IO [(Linkable,Bool)] + getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 = let scc = flattenSCC scc0 @@ -709,10 +808,10 @@ getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 -- force a module's SOURCE imports to be already compiled for -- its object linkable to be valid. - has_object m = - case findModuleLinkable_maybe (map fst new_linkables) m of - Nothing -> False - Just l -> isObjectLinkable l + -- The new_linkables is only the *valid* linkables below here + has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of + Nothing -> False + Just l -> isObjectLinkable l objects_allowed = mode == Batch || all has_object scc_allhomeimps in do @@ -809,9 +908,9 @@ hptLinkables hpt = map hm_linkable (moduleEnvElts hpt) preUpsweep :: [Linkable] -- new valid linkables -> [Module] -- names of all mods encountered in downsweep - -> [Module] -- accumulating stable modules + -> [ModSummary] -- accumulating stable modules -> [SCC ModSummary] -- scc-ified mod graph, including src imps - -> IO [Module] -- stable modules + -> IO [ModSummary] -- stable modules preUpsweep valid_lis all_home_mods stable [] = return stable preUpsweep valid_lis all_home_mods stable (scc0:sccs) @@ -821,38 +920,23 @@ preUpsweep valid_lis all_home_mods stable (scc0:sccs) = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc)) all_imports_in_scc_or_stable = all in_stable_or_scc scc_allhomeimps - scc_names - = map ms_mod scc - in_stable_or_scc m - = m `elem` scc_names || m `elem` stable + scc_mods = map ms_mod scc + stable_names = scc_mods ++ map ms_mod stable + in_stable_or_scc m = m `elem` stable_names -- now we check for valid linkables: each module in the SCC must -- have a valid linkable (see getValidLinkables above). - has_valid_linkable new_summary - = isJust (findModuleLinkable_maybe valid_lis modname) - where modname = ms_mod new_summary + has_valid_linkable scc_mod + = isJust (findModuleLinkable_maybe valid_lis scc_mod) scc_is_stable = all_imports_in_scc_or_stable - && all has_valid_linkable scc + && all has_valid_linkable scc_mods if scc_is_stable - then preUpsweep valid_lis all_home_mods (scc_names++stable) sccs - else preUpsweep valid_lis all_home_mods stable sccs + then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs + else preUpsweep valid_lis all_home_mods stable sccs --- Helper for preUpsweep. Assuming that new_summary's imports are all --- stable (in the sense of preUpsweep), determine if new_summary is itself --- stable, and, if so, in batch mode, return its linkable. -findInSummaries :: [ModSummary] -> Module -> [ModSummary] -findInSummaries old_summaries mod_name - = [s | s <- old_summaries, ms_mod s == mod_name] - -findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary -findModInSummaries old_summaries mod - = case [s | s <- old_summaries, ms_mod s == mod] of - [] -> Nothing - (s:_) -> Just s - -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] @@ -878,7 +962,6 @@ findPartiallyCompletedCycles modsDone theGraph -- There better had not be any cyclic groups here -- we check for them. upsweep_mods :: HscEnv -- Includes up-to-date HPT -> [Linkable] -- Valid linkables - -> (Module -> [Module]) -- to construct downward closures -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... @@ -886,31 +969,30 @@ upsweep_mods :: HscEnv -- Includes up-to-date HPT HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep_mods hsc_env oldUI reachable_from cleanup +upsweep_mods hsc_env oldUI cleanup [] = return (Succeeded, hsc_env, []) -upsweep_mods hsc_env oldUI reachable_from cleanup - ((CyclicSCC ms):_) +upsweep_mods hsc_env oldUI cleanup + (CyclicSCC ms:_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleUserString.ms_mod) ms)) return (Failed, hsc_env, []) -upsweep_mods hsc_env oldUI reachable_from cleanup - ((AcyclicSCC mod):mods) +upsweep_mods hsc_env oldUI cleanup + (AcyclicSCC mod:mods) = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env))) + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod - (reachable_from (ms_mod mod)) cleanup -- Remove unwanted tmp files between compilations if failed ok_flag then return (Failed, hsc_env1, []) else do - (restOK, hsc_env2, modOKs) - <- upsweep_mods hsc_env1 oldUI reachable_from cleanup mods + (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI cleanup mods return (restOK, hsc_env2, mod:modOKs) @@ -919,11 +1001,15 @@ upsweep_mods hsc_env oldUI reachable_from cleanup upsweep_mod :: HscEnv -> UnlinkedImage -> ModSummary - -> [Module] -> IO (SuccessFlag, HscEnv) -- With updated HPT -upsweep_mod hsc_env oldUI summary1 reachable_inc_me +upsweep_mod hsc_env oldUI summary1 + | ms_boot summary1 -- The summary describes an hi-boot file, + = -- so there is nothing to do + return (Succeeded, hsc_env) + + | otherwise -- The summary describes a regular source file, so compile it = do let this_mod = ms_mod summary1 location = ms_location summary1 @@ -936,23 +1022,13 @@ upsweep_mod hsc_env oldUI summary1 reachable_inc_me let maybe_old_linkable = findModuleLinkable_maybe oldUI this_mod source_unchanged = isJust maybe_old_linkable - reachable_only = filter (/= this_mod) reachable_inc_me - - -- In interactive mode, all home modules below us *must* have an - -- interface in the HPT. We never demand-load home interfaces in - -- interactive mode. - hpt1_strictDC - = ASSERT(hsc_mode hsc_env == Batch || all (`elemUFM` hpt1) reachable_only) - retainInTopLevelEnvs reachable_only hpt1 - hsc_env_strictDC = hsc_env { hsc_HPT = hpt1_strictDC } - old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable have_object | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - compresult <- compile hsc_env_strictDC this_mod location + compresult <- compile hsc_env this_mod location (ms_hs_date summary1) source_unchanged have_object mb_old_iface @@ -978,63 +1054,51 @@ upsweep_mod hsc_env oldUI summary1 reachable_inc_me -- Filter modules in the HPT retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt - = listToUFM (concatMap (maybeLookupUFM hpt) keep_these) + = mkModuleEnv [ (mod, fromJust mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupModuleEnv hpt mod + , isJust mb_mod_info ] + +----------------------------------------------------------------------------- +topological_sort :: Bool -- Drop hi-boot nodes? (see below) + -> [ModSummary] + -> [SCC ModSummary] +-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- False: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- True: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can by cyclic + +topological_sort drop_hi_boot_nodes summaries + = stronglyConnComp nodes where - maybeLookupUFM ufm u = case lookupUFM ufm u of - Nothing -> [] - Just val -> [(u, val)] - --- Needed to clean up HPT so that we don't get duplicates in inst env -downwards_closure_of_module :: [ModSummary] -> Module -> [Module] -downwards_closure_of_module summaries root - = let toEdge :: ModSummary -> (Module,[Module]) - toEdge summ = (ms_mod summ, - filter (`elem` all_mods) (ms_allimps summ)) - - all_mods = map ms_mod summaries - - res = simple_transitive_closure (map toEdge summaries) [root] - in --- trace (showSDoc (text "DC of mod" <+> ppr root --- <+> text "=" <+> ppr res)) $ - res - --- Calculate transitive closures from a set of roots given an adjacency list -simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a] -simple_transitive_closure graph set - = let set2 = nub (concatMap dsts set ++ set) - dsts node = fromMaybe [] (lookup node graph) - in - if length set == length set2 - then set - else simple_transitive_closure graph set2 - - --- Calculate SCCs of the module graph, with or without taking into --- account source imports. -topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary] -topological_sort include_source_imports summaries - = let - toEdge :: ModSummary -> (ModSummary,Module,[Module]) - toEdge summ - = (summ, ms_mod summ, - (if include_source_imports - then ms_srcimps summ else []) ++ ms_imps summ) - - mash_edge :: (ModSummary,Module,[Module]) -> (ModSummary,Int,[Int]) - mash_edge (summ, m, m_imports) - = case lookup m key_map of - Nothing -> panic "reverse_topological_sort" - Just mk -> (summ, mk, - -- ignore imports not from the home package - mapCatMaybes (flip lookup key_map) m_imports) - - edges = map toEdge summaries - key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(Module,Int)] - scc_input = map mash_edge edges - sccs = stronglyConnComp scc_input - in - sccs + keep_hi_boot_nodes = not drop_hi_boot_nodes + + -- We use integers as the keys for the SCC algorithm + nodes :: [(ModSummary, Int, [Int])] + nodes = [(s, fromJust (lookup_key (ms_boot s) (ms_mod s)), + out_edge_keys keep_hi_boot_nodes (ms_srcimps s) ++ + out_edge_keys False (ms_imps s) ) + | s <- summaries + , not (ms_boot s) || keep_hi_boot_nodes ] + -- Drop the hi-boot ones if told to do so + + key_map :: NodeMap Int + key_map = listToFM ([(ms_mod s, ms_boot s) | s <- summaries] + `zip` [1..]) + + lookup_key :: IsBootInterface -> Module -> Maybe Int + lookup_key hi_boot mod = lookupFM key_map (mod, hi_boot) + + out_edge_keys :: IsBootInterface -> [Module] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False ----------------------------------------------------------------------------- @@ -1052,15 +1116,11 @@ downsweep :: DynFlags -> [FilePath] -> [ModSummary] -> IO [ModSummary] downsweep dflags roots old_summaries = do rootSummaries <- mapM getRootSummary roots checkDuplicates rootSummaries - all_summaries - <- loop (concat (map (\ m -> zip (repeat (fromMaybe "" (ml_hs_file (ms_location m)))) - (ms_imps m)) rootSummaries)) - (mkModuleEnv [ (mod, s) | s <- rootSummaries, - let mod = ms_mod s, - isHomeModule dflags mod - ]) - return all_summaries + loop rootSummaries emptyNodeMap where + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap [ (msKey s, s) | s <- old_summaries] + getRootSummary :: FilePath -> IO ModSummary getRootSummary file | isHaskellSrcFilename file @@ -1073,7 +1133,7 @@ downsweep dflags roots old_summaries exists <- doesFileExist lhs_file if exists then summariseFile dflags lhs_file else do let mod_name = mkModule file - maybe_summary <- getSummary (file, mod_name) + maybe_summary <- getSummary file False {- Not hi-boot -} mod_name case maybe_summary of Nothing -> packageModErr mod_name Just s -> return s @@ -1097,34 +1157,41 @@ downsweep dflags roots old_summaries [ fromJust (ml_hs_file (ms_location summ')) | summ' <- summaries, ms_mod summ' == modl ] - getSummary :: (FilePath,Module) -> IO (Maybe ModSummary) - getSummary (currentMod,mod) - = do found <- findModule dflags mod True{-explicit-} + loop :: [ModSummary] -- Work list: process the imports of these modules + -> NodeMap ModSummary -- Visited set + -> IO [ModSummary] -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (nodeMapElts done) + loop (s:ss) done | key `elemFM` done = loop ss done + | otherwise = do { new_ss <- children s + ; loop (new_ss ++ ss) (addToFM done key s) } + where + key = (ms_mod s, ms_boot s) + + children :: ModSummary -> IO [ModSummary] + children s = do { mb_kids1 <- mapM (getSummary cur_path True) (ms_srcimps s) + ; mb_kids2 <- mapM (getSummary cur_path False) (ms_imps s) + ; return (catMaybes mb_kids1 ++ catMaybes mb_kids2) } + -- The Nothings are the ones from other packages: ignore + where + cur_path = fromJust (ml_hs_file (ms_location s)) + + getSummary :: FilePath -- Import directive is in here [only used for err msg] + -> IsBootInterface -- Look for an hi-boot file? + -> Module -- Look for this module + -> IO (Maybe ModSummary) + getSummary cur_mod is_boot wanted_mod + = do found <- findModule dflags wanted_mod True {-explicit-} case found of - Found location pkg -> do - let old_summary = findModInSummaries old_summaries mod - summarise dflags mod location old_summary - - err -> throwDyn (noModError dflags currentMod mod err) - - -- loop invariant: env doesn't contain package modules - loop :: [(FilePath,Module)] -> ModuleEnv ModSummary -> IO [ModSummary] - loop [] env = return (moduleEnvElts env) - loop imps env - = do -- imports for modules we don't already have - let needed_imps = nub (filter (not . (`elemUFM` env).snd) imps) + Found location pkg + | isHomePackage pkg -- Drop an external-package modules + -> do { let old_summary = lookupFM old_summary_map (wanted_mod, is_boot) + ; summarise dflags wanted_mod is_boot location old_summary } + | otherwise + -> return Nothing -- External package module - -- summarise them - needed_summaries <- mapM getSummary needed_imps + err -> throwDyn (noModError dflags cur_mod wanted_mod err) - -- get just the "home" modules - let new_home_summaries = [ s | Just s <- needed_summaries ] - - -- loop, checking the new imports - let new_imps = concat (map (\ m -> zip (repeat (fromMaybe "" (ml_hs_file (ms_location m)))) - (ms_imps m)) new_home_summaries) - loop new_imps (extendModuleEnvList env - [ (ms_mod s, s) | s <- new_home_summaries ]) -- ToDo: we don't have a proper line number for this error noModError dflags loc mod_nm err @@ -1165,51 +1232,55 @@ summariseFile dflags file Nothing -> noHsFileErr mod Just src_fn -> getModificationTime src_fn - return (ModSummary { ms_mod = mod, - ms_location = location{ ml_hspp_file = Just hspp_fn, - ml_hspp_buf = Just buf }, + return (ModSummary { ms_mod = mod, ms_boot = False, + ms_location = location{ml_hspp_file=Just hspp_fn}, ms_srcimps = srcimps, ms_imps = the_imps, ms_hs_date = src_timestamp }) -- Summarise a module, and pick up source and timestamp. -summarise :: DynFlags -> Module -> ModLocation -> Maybe ModSummary - -> IO (Maybe ModSummary) -summarise dflags mod location old_summary - | not (isHomeModule dflags mod) = return Nothing - | otherwise - = do let hs_fn = expectJust "summarise" (ml_hs_file location) - - case ml_hs_file location of { - Nothing -> noHsFileErr mod; - Just src_fn -> do - - src_timestamp <- getModificationTime src_fn +summarise :: DynFlags + -> Module -- Guaranteed a home-package module + -> IsBootInterface + -> ModLocation -> Maybe ModSummary + -> IO (Maybe ModSummary) +summarise dflags mod is_boot location old_summary + = do { -- Find the source file to summarise + src_fn <- if is_boot then + hiBootFilePath location + else + case ml_hs_file location of + Nothing -> noHsFileErr mod + Just src_fn -> return src_fn + + -- Find its timestamp + ; src_timestamp <- getModificationTime src_fn -- return the cached summary if the source didn't change - case old_summary of { - Just s | ms_hs_date s == src_timestamp -> return (Just s); - _ -> do + ; case old_summary of { + Just s | ms_hs_date s == src_timestamp -> return (Just s); + _ -> do - hspp_fn <- preprocess dflags hs_fn - - buf <- hGetStringBuffer hspp_fn - (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn - let + -- For now, we never pre-process hi-boot files + { hspp_fn <- if is_boot then return src_fn + else preprocess dflags src_fn + + ; buf <- hGetStringBuffer hspp_fn + ; (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn + ; let -- GHC.Prim doesn't exist physically, so don't go looking for it. - the_imps = filter (/= gHC_PRIM) imps + the_imps = filter (/= gHC_PRIM) imps - when (mod_name /= mod) $ + ; when (mod_name /= mod) $ throwDyn (ProgramError - (showSDoc (text hs_fn + (showSDoc (text src_fn <> text ": file name does not match module name" <+> quotes (ppr mod)))) - return (Just (ModSummary mod location{ ml_hspp_file = Just hspp_fn, - ml_hspp_buf = Just buf } - srcimps the_imps src_timestamp)) - } - } - + ; let new_loc = location{ ml_hspp_file = Just hspp_fn, + ml_hspp_buf = Just buf } + ; return (Just (ModSummary mod is_boot new_loc + srcimps the_imps src_timestamp)) + }}} noHsFileErr mod = throwDyn (CmdLineError (showSDoc (text "no source file for module" <+> quotes (ppr mod)))) @@ -1227,44 +1298,3 @@ multiRootsErr mod files \end{code} -%************************************************************************ -%* * - The ModSummary Type -%* * -%************************************************************************ - -\begin{code} --- The ModLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. - - -type ModuleGraph = [ModSummary] -- the module graph, topologically sorted - -emptyMG :: ModuleGraph -emptyMG = [] - -data ModSummary - = ModSummary { - ms_mod :: Module, -- name, package - ms_location :: ModLocation, -- location - ms_srcimps :: [Module], -- source imports - ms_imps :: [Module], -- non-source imports - ms_hs_date :: ClockTime -- timestamp of summarised file - } - -instance Outputable ModSummary where - ppr ms - = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), - text "ms_mod =" <+> ppr (ms_mod ms) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - -ms_allimps ms = ms_srcimps ms ++ ms_imps ms -\end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 06000d7..ea3d318 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -15,7 +15,7 @@ import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, HsBindGroup(..), LRuleDecl, HsBind(..) ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import MkIface ( mkUsageInfo ) -import Id ( Id, setIdExported, idName, idIsFrom, isLocalId ) +import Id ( Id, setIdExported, idName, idIsFrom ) import Name ( Name, isExternalName ) import CoreSyn import PprCore ( pprIdRules, pprCoreExpr ) @@ -35,7 +35,7 @@ import VarSet import Bag ( Bag, isEmptyBag, emptyBag, bagToList ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars ) -import Packages ( PackageState(thPackageId) ) +import Packages ( PackageState(thPackageId), PackageIdH(..) ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, errorsFound, WarnMsg ) import ListSetOps ( insertList ) @@ -114,7 +114,7 @@ deSugar hsc_env ; th_used <- readIORef th_var -- Whether TH is used ; let used_names = allUses dus `unionNameSets` dfun_uses thPackage = thPackageId (pkgState dflags) - pkgs | Just th_id <- thPackage, th_used + pkgs | ExtPackage th_id <- thPackage, th_used = insertList th_id (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index e656ab0..a188e0b 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -79,7 +79,7 @@ type DsWarning = (SrcSpan, SDoc) data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling ds_warns :: IORef (Bag DsWarning), -- Warning messages - ds_if_env :: IfGblEnv -- Used for looking up global, + ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things } @@ -109,9 +109,10 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env thing_inside = do { warn_var <- newIORef emptyBag - ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) } + ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } + ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) ; gbl_env = DsGblEnv { ds_mod = mod, - ds_if_env = if_env, + ds_if_env = (if_genv, if_lenv), ds_warns = warn_var } ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, ds_loc = noSrcSpan } } @@ -192,7 +193,7 @@ dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal dsLookupGlobal name = do { env <- getGblEnv - ; setEnvs (ds_if_env env, ()) + ; setEnvs (ds_if_env env) (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 3b50555..c6d650e 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.182 2005/01/12 12:44:25 ross Exp $ +-- $Id: InteractiveUI.hs,v 1.183 2005/01/18 12:18:19 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -26,7 +26,6 @@ import DriverState import DriverUtil ( remove_spaces ) import Linker ( showLinkerState, linkPackages ) import Util -import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, NamedThing(..) ) import OccName ( OccName, isSymOcc, occNameUserString ) import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) @@ -972,22 +971,10 @@ showCmd str = ["linker"] -> io showLinkerState _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") -showModules = do - cms <- getCmState - let (mg, hpt) = cmGetModInfo cms - mapM_ (showModule hpt) mg - - -showModule :: HomePackageTable -> ModSummary -> GHCi () -showModule hpt mod_summary - = case lookupModuleEnv hpt mod of - Nothing -> panic "missing linkable" - Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) - where - obj_linkable = isObjectLinkable (hm_linkable mod_info) - where - mod = ms_mod mod_summary - locn = ms_location mod_summary +showModules + = do { cms <- getCmState + ; let show_one ms = io (putStrLn (cmShowModule cms ms)) + ; mapM_ show_one (cmGetModuleGraph cms) } showBindings = do cms <- getCmState diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index f897eec..f4b7922 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -122,7 +122,7 @@ emptyPLS dflags = PersistentLinkerState { -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. where init_pkgs - | Just rts_id <- rtsPackageId (pkgState dflags) = [rts_id] + | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id] | otherwise = [] \end{code} @@ -386,7 +386,7 @@ getLinkDeps dflags hpt pit mods -- Get the things needed for the specified module -- This is rather similar to the code in RnNames.importsFromImportDecl get_deps mod - | ExternalPackage p <- mi_package iface + | ExtPackage p <- mi_package iface = ([], p : dep_pkgs deps) | otherwise = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 0d9f619..8570f6b 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -14,6 +14,7 @@ import BasicTypes import NewDemand import IfaceSyn import VarEnv +import Packages ( PackageIdH(..) ) import Class ( DefMeth(..) ) import CostCentre import DriverState ( v_Build_tag ) @@ -158,7 +159,7 @@ instance Binary ModIface where rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh return (ModIface { - mi_package = ThisPackage, -- to be filled in properly later + mi_package = HomePackage, -- to be filled in properly later mi_module = mod_name, mi_mod_vers = mod_vers, mi_boot = False, -- Binary interfaces are never .hi-boot files! diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index bb51778..40cae9d 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -51,7 +51,8 @@ data IfaceExtName -- of whether they are home-pkg or not | HomePkg Module OccName Version -- From another module in home package; - -- has version # + -- has version #; in all other respects, + -- HomePkg and ExtPkg are the same | LocalTop OccName -- Top-level from the same module as -- the enclosing IfaceDecl diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index ef52bdb..142d86f 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -17,7 +17,7 @@ module LoadIface ( import {-# SOURCE #-} TcIface( tcIfaceDecl ) -import Packages ( PackageState(..), isHomeModule ) +import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( replaceFilenameSuffix ) import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) @@ -32,7 +32,7 @@ import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupOrig ) import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), - PackageTypeEnv, emptyTypeEnv, IfacePackage(..), + PackageTypeEnv, emptyTypeEnv, lookupIfaceByModule, emptyPackageIfaceTable, IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings, addRulesToPool, addInstsToPool, @@ -62,16 +62,16 @@ import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataC import Class ( Class, className ) import TyCon ( tyConName ) import SrcLoc ( mkSrcLoc, importedSrcLoc ) -import Maybes ( isJust, mapCatMaybes ) +import Maybes ( mapCatMaybes, MaybeErr(..) ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message, mkLocMessage ) import Finder ( findModule, findPackageModule, FindResult(..), - hiBootExt, hiBootVerExt ) + hiBootFilePath ) import Lexer import Outputable import BinIface ( readBinIface ) -import Panic +import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) import DATA_IOREF ( readIORef ) @@ -97,8 +97,8 @@ loadSrcInterface doc mod_name want_boot = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name (ImportByUser want_boot) ; case mb_iface of - Left err -> failWithTc (elaborate err) - Right iface -> return iface + Failed err -> failWithTc (elaborate err) + Succeeded iface -> return iface } where elaborate err = hang (ptext SLIT("Failed to load interface for") <+> @@ -170,8 +170,8 @@ loadSysInterface :: SDoc -> Module -> IfM lcl ModIface loadSysInterface doc mod_name = do { mb_iface <- loadInterface doc mod_name ImportBySystem ; case mb_iface of - Left err -> ghcError (ProgramError (showSDoc err)) - Right iface -> return iface } + Failed err -> ghcError (ProgramError (showSDoc err)) + Succeeded iface -> return iface } \end{code} @@ -187,7 +187,7 @@ loadSysInterface doc mod_name \begin{code} loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (Either Message ModIface) + -> IfM lcl (MaybeErr Message ModIface) -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry -- (to avoid repeated complaints) @@ -195,19 +195,18 @@ loadInterface :: SDoc -> Module -> WhereFrom -- -- It's not necessarily an error for there not to be an interface -- file -- perhaps the module has changed, and that interface --- is no longer used -- but the caller can deal with that by --- catching the exception +-- is no longer used -loadInterface doc_str mod_name from +loadInterface doc_str mod from = do { -- Read the state (eps,hpt) <- getEpsAndHpt - ; traceIf (text "Considering whether to load" <+> ppr mod_name <+> ppr from) + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModule hpt (eps_PIT eps) mod_name of { + ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface - -> returnM (Right iface) ; -- Already loaded + -> returnM (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, -- if an earlier import had a before we got to real imports. I think. @@ -217,7 +216,7 @@ loadInterface doc_str mod_name from ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod_name + ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -227,32 +226,33 @@ loadInterface doc_str mod_name from -- READ THE MODULE IN ; let explicit | ImportByUser _ <- from = True | otherwise = False - ; read_result <- findAndReadIface explicit doc_str mod_name hi_boot_file + ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file ; dflags <- getDOpts ; case read_result of { - Left err -> do - { let fake_iface = emptyModIface ThisPackage mod_name + Failed err -> do + { let fake_iface = emptyModIface HomePackage mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } -- Not found, so add an empty iface to -- the EPS map so that we don't look again - ; returnM (Left err) } ; + ; returnM (Failed err) } ; -- Found and parsed! - Right iface -> + Succeeded (iface, file_path) -- Sanity check: + | ImportBySystem <- from, -- system-importing... + isHomePackage (mi_package iface), -- ...a home-package module + Nothing <- mb_dep -- ...that we know nothing about + -> returnM (Failed (badDepMsg mod)) - let { mod = mi_module iface } in + | otherwise -> - -- Sanity check. If we're system-importing a module we know nothing at all - -- about, it should be from a different package to this one - WARN( case from of { ImportBySystem -> True; other -> False } && - not (isJust mb_dep) && - isHomeModule dflags mod, - ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) ) + let + loc_doc = text file_path <+> colon + in + initIfaceLcl mod loc_doc $ do - initIfaceLcl mod_name $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface -- (which only happens in OneShot mode; in Batch/Interactive @@ -269,10 +269,12 @@ loadInterface doc_str mod_name from -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - { ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; new_eps_decls <- loadDecls ignore_prags mod (mi_decls iface) - ; new_eps_rules <- loadRules ignore_prags mod_name (mi_rules iface) - ; new_eps_insts <- loadInsts mod_name (mi_insts iface) + ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- mapM (loadDecl ignore_prags) (mi_decls iface) + ; new_eps_insts <- mapM loadInst (mi_insts iface) + ; new_eps_rules <- if ignore_prags + then return [] + else mapM loadRule (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", @@ -286,8 +288,13 @@ loadInterface doc_str mod_name from eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) (length new_eps_insts) (length new_eps_rules) } - ; return (Right final_iface) - }}}}} + ; return (Succeeded final_iface) + }}}} + +badDepMsg mod + = hang (ptext SLIT("Interface file inconsistency:")) + 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"), + ptext SLIT("but does not appear in the dependencies of the interface")]) ----------------------------------------------------- -- Loading type/class/value decls @@ -301,18 +308,16 @@ loadInterface doc_str mod_name from addDeclsToPTE :: PackageTypeEnv -> [[(Name,TyThing)]] -> PackageTypeEnv addDeclsToPTE pte things = foldl extendNameEnvList pte things -loadDecls :: Bool -- Don't load pragmas into the decl pool - -> Module - -> [(Version, IfaceDecl)] - -> IfL [[(Name,TyThing)]] -- The list can be poked eagerly, but the +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> (Version, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the -- TyThings are forkM'd thunks -loadDecls ignore_prags mod decls = mapM (loadDecl ignore_prags mod) decls - -loadDecl ignore_prags mod (_version, decl) +loadDecl ignore_prags (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - main_name <- mk_new_bndr Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl) + mod <- getIfModule + ; main_name <- mk_new_bndr mod Nothing (ifName decl) + ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl) @@ -334,8 +339,10 @@ loadDecl ignore_prags mod (_version, decl) -- * parent -- * location -- imported name, to fix the module correctly in the cache - mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc - loc = importedSrcLoc (moduleUserString mod) + mk_new_bndr mod mb_parent occ + = newGlobalBinder mod occ mb_parent + (importedSrcLoc (moduleUserString mod)) + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) discardDeclPrags :: IfaceDecl -> IfaceDecl @@ -399,10 +406,9 @@ ifaceDeclSubBndrs _other = [] -- Loading instance decls ----------------------------------------------------- -loadInsts :: Module -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)] -loadInsts mod decls = mapM (loadInstDecl mod) decls +loadInst :: IfaceInst -> IfL (Name, Gated IfaceInst) -loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty}) +loadInst decl@(IfaceInst {ifInstHead = inst_ty}) = do { -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then @@ -432,26 +438,21 @@ loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty}) let { (cls_ext, tc_exts) = ifaceInstGates inst_ty } ; cls <- lookupIfaceExt cls_ext ; tcs <- mapM lookupIfaceTc tc_exts - ; returnM (cls, (tcs, (mod,decl))) + ; (mod, doc) <- getIfCtxt + ; returnM (cls, (tcs, (mod, doc, decl))) } ----------------------------------------------------- -- Loading Rules ----------------------------------------------------- -loadRules :: Bool -- Don't load pragmas into the decl pool - -> Module - -> [IfaceRule] -> IfL [Gated IfaceRule] -loadRules ignore_prags mod rules - | ignore_prags = returnM [] - | otherwise = mapM (loadRule mod) rules - -loadRule :: Module -> IfaceRule -> IfL (Gated IfaceRule) +loadRule :: IfaceRule -> IfL (Gated IfaceRule) -- "Gate" the rule simply by a crude notion of the free vars of -- the LHS. It can be crude, because having too few free vars is safe. -loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) +loadRule decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) = do { names <- mapM lookupIfaceExt (fn : arg_fvs) - ; returnM (names, (mod, decl)) } + ; (mod, doc) <- getIfCtxt + ; returnM (names, (mod, doc, decl)) } where arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg] @@ -479,6 +480,11 @@ get_tcs (IfaceTyConApp other ts) = get_tcs_s ts -- The lists are always small => appending is fine get_tcs_s :: [IfaceType] -> [IfaceExtName] get_tcs_s tys = foldr ((++) . get_tcs) [] tys + + +---------------- +getIfCtxt :: IfL (Module, SDoc) +getIfCtxt = do { env <- getLclEnv; return (if_mod env, if_loc env) } \end{code} @@ -540,7 +546,7 @@ findAndReadIface :: Bool -- True <=> explicit user import -> SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> IfM lcl (Either Message ModIface) + -> IfM lcl (MaybeErr Message (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -558,41 +564,37 @@ findAndReadIface explicit doc_str mod_name hi_boot_file -- Check for GHC.Prim, and return its static interface ; dflags <- getDOpts - ; let base_id = basePackageId (pkgState dflags) - base_pkg - | Just id <- base_id = ExternalPackage id - | otherwise = ThisPackage - -- if basePackageId is Nothing, it means we must be - -- compiling the base package. + ; let base_pkg = basePackageId (pkgState dflags) ; if mod_name == gHC_PRIM - then returnM (Right (ghcPrimIface{ mi_package = base_pkg })) + then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg }, + "")) else do -- Look for the file ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file) ; case mb_found of { - Left err -> do + Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Left (noIfaceErr dflags mod_name err)) } ; + ; returnM (Failed (noIfaceErr dflags mod_name err)) } ; - Right (file_path,pkg) -> do + Succeeded (file_path, pkg) -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) ; read_result <- readIface mod_name file_path hi_boot_file ; case read_result of - Left err -> returnM (Left (badIfaceFile file_path err)) - Right iface + Failed err -> returnM (Failed (badIfaceFile file_path err)) + Succeeded iface | mi_module iface /= mod_name -> - return (Left (wrongIfaceModErr iface mod_name file_path)) + return (Failed (wrongIfaceModErr iface mod_name file_path)) | otherwise -> - returnM (Right iface{mi_package=pkg}) - -- don't forget to fill in the package name... + returnM (Succeeded (iface{mi_package=pkg}, file_path)) + -- Don't forget to fill in the package name... }}} findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface - -> IO (Either FindResult (FilePath, IfacePackage)) + -> IO (MaybeErr FindResult (FilePath, PackageIdH)) findHiFile dflags explicit mod_name hi_boot_file = do { -- In interactive or --make mode, we are *not allowed* to demand-load @@ -607,35 +609,22 @@ findHiFile dflags explicit mod_name hi_boot_file then findModule dflags mod_name explicit else findPackageModule dflags mod_name explicit; - case maybe_found of { - Found loc pkg -> foundOk loc hi_boot_file pkg; - err -> return (Left err) ; - }} - where - foundOk loc hi_boot_file pkg = do { -- Don't need module returned by finder - - -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate - let { hi_path = ml_hi_file loc ; - hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; - hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt - }; - - if not hi_boot_file then - return (Right (hi_path,pkg)) - else do { - hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right (hi_boot_ver_path,pkg)) - else return (Right (hi_boot_path,pkg)) - }} + case maybe_found of + Found loc pkg + | hi_boot_file -> do { hi_boot_path <- hiBootFilePath loc + ; return (Succeeded (hi_boot_path, pkg)) } + | otherwise -> return (Succeeded (ml_hi_file loc, pkg)) ; + err -> return (Failed err) + } \end{code} @readIface@ tries just the one file. \begin{code} readIface :: Module -> String -> IsBootInterface - -> IfM lcl (Either Message ModIface) - -- Left err <=> file not found, or unreadable, or illegible - -- Right iface <=> successfully found and parsed + -> IfM lcl (MaybeErr Message ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed readIface wanted_mod_name file_path is_hi_boot_file = do { dflags <- getDOpts @@ -645,13 +634,13 @@ read_iface dflags wanted_mod file_path is_hi_boot_file | is_hi_boot_file -- Read ascii = do { res <- tryMost (hGetStringBuffer file_path) ; case res of { - Left exn -> return (Left (text (showException exn))) ; + Left exn -> return (Failed (text (showException exn))) ; Right buffer -> case unP parseIface (mkPState buffer loc dflags) of - PFailed span err -> return (Left (mkLocMessage span err)) + PFailed span err -> return (Failed (mkLocMessage span err)) POk _ iface - | wanted_mod == actual_mod -> return (Right iface) - | otherwise -> return (Left err) + | wanted_mod == actual_mod -> return (Succeeded iface) + | otherwise -> return (Failed err) where actual_mod = mi_module iface err = hiModuleNameMismatchWarn wanted_mod actual_mod @@ -660,8 +649,8 @@ read_iface dflags wanted_mod file_path is_hi_boot_file | otherwise -- Read binary = do { res <- tryMost (readBinIface file_path) ; case res of - Right iface -> return (Right iface) - Left exn -> return (Left (text (showException exn))) } + Right iface -> return (Succeeded iface) + Left exn -> return (Failed (text (showException exn))) } where loc = mkSrcLoc (mkFastString file_path) 1 0 \end{code} @@ -691,7 +680,8 @@ initExternalPackageState } where mk_gated_rule (fn_name, core_rule) - = ([fn_name], (nameModule fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) + = ([fn_name], (nameModule fn_name, ptext SLIT(""), + IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) \end{code} @@ -704,7 +694,7 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface ThisPackage gHC_PRIM) { + = (emptyModIface HomePackage gHC_PRIM) { mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, @@ -758,6 +748,7 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] +noIfaceErr :: DynFlags -> Module -> FindResult -> SDoc noIfaceErr dflags mod_name (PackageHidden pkg) = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon $$ ptext SLIT("it is a member of package") <+> ppr pkg <> comma diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index d57994e..8fa008f 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -174,7 +174,7 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import HsSyn -import Packages ( isHomeModule ) +import Packages ( isHomeModule, PackageIdH(..) ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, @@ -185,7 +185,7 @@ import BasicTypes ( Version, initialVersion, bumpVersion ) import TcRnMonad import TcRnTypes ( mkModDeps ) import TcType ( isFFITy ) -import HscTypes ( ModIface(..), TyThing(..), IfacePackage(..), +import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, GhciMode(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), @@ -234,7 +234,8 @@ import FastString import DATA_IOREF ( writeIORef ) import Monad ( when ) import List ( insert ) -import Maybes ( orElse, mapCatMaybes, isNothing, isJust, fromJust, expectJust ) +import Maybes ( orElse, mapCatMaybes, isNothing, isJust, + fromJust, expectJust, MaybeErr(..) ) \end{code} @@ -293,7 +294,7 @@ mkIface hsc_env location maybe_old_iface ; intermediate_iface = ModIface { mi_module = this_mod, - mi_package = ThisPackage, + mi_package = HomePackage, mi_boot = False, mi_deps = deps, mi_usages = usages, @@ -836,12 +837,12 @@ check_old_iface this_mod iface_path source_unchanged maybe_iface -- from the .hi file left from the last time we compiled it readIface this_mod iface_path False `thenM` \ read_result -> case read_result of { - Left err -> -- Old interface file not found, or garbled; give up + Failed err -> -- Old interface file not found, or garbled; give up traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) `thenM_` returnM (outOfDate, Nothing) - ; Right iface -> + ; Succeeded iface -> -- We have got the old iface; check its versions checkVersions source_unchanged iface `thenM` \ recomp -> @@ -908,13 +909,13 @@ checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, -- Instead, get an Either back which we can test case mb_iface of { - Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), ppr mod_name])); -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted - Right iface -> + Succeeded iface -> let new_mod_vers = mi_mod_vers iface new_decl_vers = mi_ver_fn iface @@ -1030,8 +1031,8 @@ pprModIface iface , pprDeprecs (mi_deprecs iface) ] where - ppr_package ThisPackage = empty - ppr_package (ExternalPackage id) = doubleQuotes (ftext id) + ppr_package HomePackage = empty + ppr_package (ExtPackage id) = doubleQuotes (ppr id) exp_vers = mi_exp_vers iface rule_vers = mi_rule_vers iface diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 0f3cca2..e957e50 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -9,10 +9,11 @@ module TcIface ( loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where + #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags ) +import LoadIface ( loadHomeInterface, loadInterface, predInstGates, discardDeclPrags ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, @@ -56,6 +57,8 @@ import OccName ( OccName ) import Module ( Module ) import UniqSupply ( initUs_ ) import Outputable +import ErrUtils ( Message ) +import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength, zipLazy ) import CmdLineOpts ( DynFlag(..) ) @@ -105,36 +108,45 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. \begin{code} -tcImportDecl :: Name -> IfG TyThing +tcImportDecl :: Name -> TcM TyThing +-- Entry point for source-code uses of importDecl +tcImportDecl name + = do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; mb_thing <- initIfaceTcRn (importDecl name) + ; case mb_thing of + Succeeded thing -> return thing + Failed err -> failWithTc err } + +importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -tcImportDecl name +importDecl name | Just thing <- wiredInNameTyThing_maybe name -- This case only happens for tuples, because we pre-populate the eps_PTE -- with other wired-in things. We can't do that for tuples because we -- don't know how many of them we'll find = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing }) - ; return thing } + ; return (Succeeded thing) } | otherwise = do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; loadHomeInterface nd_doc name + ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded iface -> do -- Now look it up again; this time we should find it - ; eps <- getEps + { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of - Just thing -> return thing - Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM } - -- Declaration not found! - -- No errors-var to accumulate errors in, so just - -- print out the error right now - } + Just thing -> return (Succeeded thing) + Nothing -> return (Failed not_found_msg) + }}} where nd_doc = ptext SLIT("Need decl for") <+> ppr name - msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) - 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), - ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) + not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) + 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), + ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} %************************************************************************ @@ -428,7 +440,7 @@ loadImportedInsts cls tys do { eps <- getEps; return (eps_inst_env eps) } else do { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, - nest 2 (vcat (map ppr iface_insts))]) + nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])]) -- Typecheck the new instances ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) @@ -443,13 +455,16 @@ loadImportedInsts cls tys where wired_doc = ptext SLIT("Need home inteface for wired-in thing") -tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst) +tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst) + where + full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst)) tcIfaceInst :: IfaceInst -> IfL DFunId tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) = tcIfaceExtId (LocalTop dfun_occ) -selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(Module, IfaceInst)]) +selectInsts :: Name -> [Name] -> ExternalPackageState + -> (ExternalPackageState, [(Module, SDoc, IfaceInst)]) selectInsts cls tycons eps = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts) where @@ -499,9 +514,8 @@ loadImportedRules hsc_env guts { -- Get new rules if_rules <- updateEps selectRules - ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules)) + ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules]) - ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) ; core_rules <- mapM tc_rule if_rules -- Debug print @@ -520,8 +534,11 @@ loadImportedRules hsc_env guts ; return core_rules } - -selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, IfaceRule)]) +tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule) + where + full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule)) + +selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)]) -- Not terribly efficient. Look at each rule in the pool to see if -- all its gates are in the type env. If so, take it out of the pool. -- If not, trim its gates for next time. @@ -740,20 +757,20 @@ tcVanillaAlt data_con inst_tys arg_occs rhs \begin{code} -tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core -tcExtCoreBindings mod [] = return [] -tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs) +tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core +tcExtCoreBindings [] = return [] +tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs) -do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] -do_one mod (IfaceNonRec bndr rhs) thing_inside +do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] +do_one (IfaceNonRec bndr rhs) thing_inside = do { rhs' <- tcIfaceExpr rhs - ; bndr' <- newExtCoreBndr mod bndr + ; bndr' <- newExtCoreBndr bndr ; extendIfaceIdEnv [bndr'] $ do { core_binds <- thing_inside ; return (NonRec bndr' rhs' : core_binds) }} -do_one mod (IfaceRec pairs) thing_inside - = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs +do_one (IfaceRec pairs) thing_inside + = do { bndrs' <- mappM newExtCoreBndr bndrs ; extendIfaceIdEnv bndrs' $ do { rhss' <- mappM tcIfaceExpr rhss ; core_binds <- thing_inside @@ -865,28 +882,31 @@ tcPragExpr name expr %************************************************************************ \begin{code} -tcIfaceGlobal :: Name -> IfM a TyThing +tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name = do { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of { Just thing -> return thing ; - Nothing -> + Nothing -> do - setLclEnv () $ do -- This gets us back to IfG, mainly to - -- pacify get_type_env; rather untidy { env <- getGblEnv ; case if_rec_types env of Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled - { type_env <- get_type_env + { type_env <- setLclEnv () get_type_env -- yuk ; case lookupNameEnv type_env name of Just thing -> return thing Nothing -> pprPanic "tcIfaceGlobal (local): not found:" (ppr name $$ ppr type_env) } - other -> tcImportDecl name -- It's imported; go get it - }}} + other -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}}} tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = return intTyCon @@ -958,9 +978,10 @@ bindIfaceIds bndrs thing_inside ----------------------- -newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id -newExtCoreBndr mod (occ, ty) - = do { name <- newGlobalBinder mod occ Nothing noSrcLoc +newExtCoreBndr :: (OccName, IfaceType) -> IfL Id +newExtCoreBndr (occ, ty) + = do { mod <- getIfModule + ; name <- newGlobalBinder mod occ Nothing noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 3a3e4bb..2c37777 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -245,7 +245,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) -- we need the #includes from the rts package for the stub files let rtsid = rtsPackageId (pkgState dflags) rts_includes - | Just pid <- rtsid = + | ExtPackage pid <- rtsid = let rts_pkg = getPackageDetails (pkgState dflags) pid in concatMap mk_include (includes rts_pkg) | otherwise = [] diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index f393462..73fba48 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.35 2005/01/14 17:57:46 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.36 2005/01/18 12:18:28 simonpj Exp $ -- -- GHC Driver -- @@ -13,12 +13,12 @@ module DriverMkDepend ( #include "HsVersions.h" -import HscTypes ( IfacePackage(..) ) import GetImports ( getImportsFromFile ) import CmdLineOpts ( DynFlags ) import DriverState import DriverUtil import DriverFlags +import Packages ( PackageIdH(..) ) import SysTools ( newTempName ) import qualified SysTools import Module ( Module, ModLocation(..), moduleUserString) @@ -248,7 +248,7 @@ findDependency dflags is_source src imp = do case r of Found loc pkg -- not in this package: we don't need a dependency - | ExternalPackage _ <- pkg, not include_prelude + | ExtPackage _ <- pkg, not include_prelude -> return Nothing -- normal import: just depend on the .hi file diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 0db881a..3b9d399 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -69,7 +69,7 @@ import Maybe preprocess :: DynFlags -> FilePath -> IO FilePath preprocess dflags filename = - ASSERT(isHaskellSrcFilename filename) + ASSERT2(isHaskellSrcFilename filename, text filename) do runPipeline (StopBefore Hsc) dflags ("preprocess") False{-temporary output file-} Nothing{-no specific output file-} @@ -1051,9 +1051,9 @@ staticLink dflags o_files dep_packages = do extra_ld_opts <- getStaticOpts v_Opt_l let pstate = pkgState dflags - rts_id | Just id <- rtsPackageId pstate = id + rts_id | ExtPackage id <- rtsPackageId pstate = id | otherwise = panic "staticLink: rts package missing" - base_id | Just id <- basePackageId pstate = id + base_id | ExtPackage id <- basePackageId pstate = id | otherwise = panic "staticLink: base package missing" rts_pkg = getPackageDetails pstate rts_id base_pkg = getPackageDetails pstate base_id @@ -1147,9 +1147,9 @@ doMkDLL dflags o_files dep_packages = do extra_ld_opts <- getStaticOpts v_Opt_dll let pstate = pkgState dflags - rts_id | Just id <- rtsPackageId pstate = id + rts_id | ExtPackage id <- rtsPackageId pstate = id | otherwise = panic "staticLink: rts package missing" - base_id | Just id <- basePackageId pstate = id + base_id | ExtPackage id <- basePackageId pstate = id | otherwise = panic "staticLink: base package missing" rts_pkg = getPackageDetails pstate rts_id base_pkg = getPackageDetails pstate base_id diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 857ae12..edae27e 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -12,6 +12,7 @@ module Finder ( mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + hiBootFilePath, -- :: ModLocation -> IO FilePath hiBootExt, -- :: String hiBootVerExt, -- :: String @@ -21,7 +22,7 @@ module Finder ( import Module import UniqFM ( filterUFM ) -import HscTypes ( Linkable(..), Unlinked(..), IfacePackage(..) ) +import HscTypes ( Linkable(..), Unlinked(..) ) import Packages import DriverState import DriverUtil @@ -86,7 +87,7 @@ lookupFinderCache mod_name = do -- that module: its source file, .hi file, object file, etc. data FindResult - = Found ModLocation IfacePackage + = Found ModLocation PackageIdH -- the module was found | PackageHidden PackageId -- for an explicit source import: the package containing the module is @@ -122,9 +123,9 @@ cached fn dflags name explicit = do | Just err <- visible explicit maybe_pkg -> return err | otherwise -> return (Found loc (pkgInfoToId maybe_pkg)) -pkgInfoToId :: Maybe (PackageConfig,Bool) -> IfacePackage -pkgInfoToId (Just (pkg,_)) = ExternalPackage (mkPackageId (package pkg)) -pkgInfoToId Nothing = ThisPackage +pkgInfoToId :: Maybe (PackageConfig,Bool) -> PackageIdH +pkgInfoToId (Just (pkg,_)) = ExtPackage (mkPackageId (package pkg)) +pkgInfoToId Nothing = HomePackage -- Is a module visible or not? Returns Nothing if the import is ok, -- or Just err if there's a visibility error. @@ -269,7 +270,7 @@ mkHiOnlyModLocation hisuf mod path basename _ext = do -- basename == dots_to_slashes (moduleNameUserString mod) loc <- hiOnlyModLocation path basename hisuf addToFinderCache mod (loc, Nothing) - return (Found loc ThisPackage) + return (Found loc HomePackage) mkPackageModLocation pkg_info hisuf mod path basename _ext = do -- basename == dots_to_slashes (moduleNameUserString mod) @@ -330,7 +331,7 @@ mkHomeModLocation mod src_filename = do mkHomeModLocationSearched mod path basename ext = do loc <- mkHomeModLocation' mod (path ++ '/':basename) ext - return (Found loc ThisPackage) + return (Found loc HomePackage) mkHomeModLocation' mod src_basename ext = do let mod_basename = dots_to_slashes (moduleUserString mod) @@ -377,6 +378,19 @@ mkHiPath basename mod_basename return (hi_basename ++ '.':hisuf) + +-------------------- +hiBootFilePath :: ModLocation -> IO FilePath +-- Return Foo.hi-boot, or Foo.hi-boot-n, as appropriate +hiBootFilePath (ModLocation { ml_hi_file = hi_path }) + = do { hi_ver_exists <- doesFileExist hi_boot_ver_path + ; if hi_ver_exists then return hi_boot_ver_path + else return hi_boot_path } + where + hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; + hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt + + -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 124397f..5a0b167 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -12,6 +12,7 @@ module HscTypes ( ModGuts(..), ModImports(..), ForeignStubs(..), HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + hptInstances, hptRules, ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -21,7 +22,7 @@ module HscTypes ( icPrintUnqual, unQualInScope, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - IfacePackage(..), emptyIfaceDepCache, + emptyIfaceDepCache, Deprecs(..), IfaceDeprecs, @@ -78,7 +79,7 @@ import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) -import Packages ( PackageId ) +import Packages ( PackageIdH, PackageId ) import CmdLineOpts ( DynFlags ) import BasicTypes ( Version, initialVersion, IPName, @@ -88,7 +89,7 @@ import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) -import Maybes ( orElse ) +import Maybes ( orElse, fromJust ) import Outputable import SrcLoc ( SrcSpan ) import UniqSupply ( UniqSupply ) @@ -125,6 +126,10 @@ data HscEnv -- hsc_HPT is not mutable because we only demand-load -- external packages; the home package is eagerly -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by --make + -- but not actually below the current module in the dependency + -- graph. (This changes a previous invariant: changed Jan 05.) -- The next two are side-effected by compiling -- to reflect sucking in interface files @@ -182,6 +187,54 @@ lookupIfaceByModule hpt pit mod Nothing -> lookupModuleEnv pit mod \end{code} + +\begin{code} +hptInstances :: HscEnv -> [(Module, IsBootInterface)] -> [DFunId] +-- Find all the instance declarations that are in modules imported +-- by this one, directly or indirectly, and are in the Home Package Table +-- This ensures that we don't see instances from modules --make compiled +-- before this one, but which are not below this one +hptInstances hsc_env deps + | isOneShot (hsc_mode hsc_env) = [] -- In one-shot mode, the HPT is empty + | otherwise + = let + hpt = hsc_HPT hsc_env + in + [ dfun + | -- Find each non-hi-boot module below me + (mod, False) <- deps + + -- Look it up in the HPT + , let mod_info = ASSERT2( mod `elemModuleEnv` hpt, ppr mod $$ vcat (map ppr_hm (moduleEnvElts hpt))) + fromJust (lookupModuleEnv hpt mod) + + -- And get its dfuns + , dfun <- md_insts (hm_details mod_info) ] + where + ppr_hm hm = ppr (mi_module (hm_iface hm)) + +hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [IdCoreRule] +-- Get rules from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptRules hsc_env deps + | isOneShot (hsc_mode hsc_env) = [] + | otherwise + = let + hpt = hsc_HPT hsc_env + in + [ rule + | -- Find each non-hi-boot module below me + (mod, False) <- deps + + -- Look it up in the HPT + , let mod_info = ASSERT( mod `elemModuleEnv` hpt ) + fromJust (lookupModuleEnv hpt mod) + + -- And get its dfuns + , rule <- md_rules (hm_details mod_info) ] +\end{code} + + %************************************************************************ %* * \subsection{Symbol tables and Module details} @@ -200,7 +253,7 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_package :: !IfacePackage, -- Which package the module comes from + mi_package :: !PackageIdH, -- Which package the module comes from mi_module :: !Module, mi_mod_vers :: !Version, -- Module version: changes when anything changes @@ -254,8 +307,6 @@ data ModIface -- seeing if we are up to date wrt the old interface } -data IfacePackage = ThisPackage | ExternalPackage PackageId - -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { @@ -338,7 +389,7 @@ data ForeignStubs = NoStubs \end{code} \begin{code} -emptyModIface :: IfacePackage -> Module -> ModIface +emptyModIface :: PackageIdH -> Module -> ModIface emptyModIface pkg mod = ModIface { mi_package = pkg, mi_module = mod, @@ -775,9 +826,10 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} \begin{code} -type Gated d = ([Name], (Module, d)) -- The [Name] 'gate' the declaration; always non-empty - -- Module records which iface file this - -- decl came from +type Gated d = ([Name], (Module, SDoc, d)) + -- The [Name] 'gate' the declaration; always non-empty + -- Module records which module this decl belongs to + -- SDoc records the pathname of the file, or similar err-ctxt info type RulePool = [Gated IfaceRule] diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 2c13c62..efe4842 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.141 2004/11/26 16:21:00 simonmar Exp $ +-- $Id: Main.hs,v 1.142 2005/01/18 12:18:34 simonpj Exp $ -- -- GHC Driver program -- @@ -26,7 +26,7 @@ import CompManager ( cmInit, cmLoadModules, cmDepAnal ) import HscTypes ( GhciMode(..) ) import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) import SysTools ( initSysTools, cleanTempFiles, normalisePath ) -import Packages ( dumpPackages, initPackages, haskell98PackageId ) +import Packages ( dumpPackages, initPackages, haskell98PackageId, PackageIdH(..) ) import DriverPipeline ( staticLink, doMkDLL, runPipeline ) import DriverState ( buildStgToDo, findBuildTag, unregFlags, @@ -219,7 +219,7 @@ main = -- Always link in the haskell98 package for static linking. Other -- packages have to be specified via the -package flag. let link_pkgs - | Just h98_id <- haskell98PackageId (pkgState dflags) = [h98_id] + | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id] | otherwise = [] case mode of diff --git a/ghc/compiler/main/PackageConfig.hs b/ghc/compiler/main/PackageConfig.hs index b29e280..e19a10d 100644 --- a/ghc/compiler/main/PackageConfig.hs +++ b/ghc/compiler/main/PackageConfig.hs @@ -6,6 +6,7 @@ module PackageConfig ( -- * PackageId PackageId, mkPackageId, stringToPackageId, packageIdString, packageConfigId, + packageIdFS, fsToPackageId, -- * The PackageConfig type: information about a package PackageConfig, @@ -43,12 +44,21 @@ defaultPackageConfig = emptyInstalledPackageInfo -- -- A PackageId is a string of the form -. -type PackageId = FastString -- includes the version +newtype PackageId = PId FastString deriving( Eq, Ord ) -- includes the version -- easier not to use a newtype here, because we need instances of -- Binary & Outputable, and we're too early to define them +fsToPackageId :: FastString -> PackageId +fsToPackageId = PId + +packageIdFS :: PackageId -> FastString +packageIdFS (PId fs) = fs + stringToPackageId :: String -> PackageId -stringToPackageId = mkFastString +stringToPackageId = fsToPackageId . mkFastString + +packageIdString :: PackageId -> String +packageIdString = unpackFS . packageIdFS mkPackageId :: PackageIdentifier -> PackageId mkPackageId = stringToPackageId . showPackageId @@ -56,5 +66,4 @@ mkPackageId = stringToPackageId . showPackageId packageConfigId :: PackageConfig -> PackageId packageConfigId = mkPackageId . package -packageIdString :: PackageId -> String -packageIdString = unpackFS + diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 081e801..93a8856 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -12,7 +12,8 @@ module Packages ( extendPackageConfigMap, dumpPackages, -- * Reading the package config, and processing cmdline args - PackageState(..), + PackageIdH(..), isHomePackage, + PackageState(..), initPackages, moduleToPackageConfig, getPackageDetails, @@ -147,12 +148,22 @@ data PackageState = PackageState { -- exposed is True if the package exposes that module. -- The PackageIds of some known packages - basePackageId :: Maybe PackageId, - rtsPackageId :: Maybe PackageId, - haskell98PackageId :: Maybe PackageId, - thPackageId :: Maybe PackageId + basePackageId :: PackageIdH, + rtsPackageId :: PackageIdH, + haskell98PackageId :: PackageIdH, + thPackageId :: PackageIdH } +data PackageIdH + = HomePackage -- The "home" package is the package curently + -- being compiled + | ExtPackage PackageId -- An "external" package is any other package + + +isHomePackage :: PackageIdH -> Bool +isHomePackage HomePackage = True +isHomePackage (ExtPackage _) = False + -- A PackageConfigMap maps a PackageId to a PackageConfig type PackageConfigMap = UniqFM PackageConfig @@ -311,12 +322,13 @@ mkPackageState dflags pkg_db = do -- Look up some known PackageIds -- let + lookupPackageByName :: FastString -> PackageIdH lookupPackageByName nm = case [ conf | p <- dep_exposed, Just conf <- [lookupPackage pkg_db p], nm == mkFastString (pkgName (package conf)) ] of - [] -> Nothing - (p:ps) -> Just (mkPackageId (package p)) + [] -> HomePackage + (p:ps) -> ExtPackage (mkPackageId (package p)) -- Get the PackageIds for some known packages (we know the names, -- but we don't know the versions). Some of these packages might @@ -329,7 +341,7 @@ mkPackageState dflags pkg_db = do -- add base & rts to the explicit packages basicLinkedPackages = [basePackageId,rtsPackageId] explicit' = addListToUniqSet explicit - [ p | Just p <- basicLinkedPackages ] + [ p | ExtPackage p <- basicLinkedPackages ] -- -- Close the explicit packages with their dependencies -- diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 9e0725f..0b5d02f 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -340,15 +340,29 @@ header_body :: { [LImportDecl RdrName] } iface :: { ModIface } : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 } -ifacebody :: { [HsDecl RdrName] } - : '{' ifacedecls '}' { $2 } - | vocurly ifacedecls close { $2 } - -ifacedecls :: { [HsDecl RdrName] } - : ifacedecl ';' ifacedecls { $1 : $3 } - | ';' ifacedecls { $2 } +ifacebody :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) } + : '{' ifacetop '}' { $2 } + | vocurly ifacetop close { $2 } + +ifacetop :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) } + : ifaceimps { ($1,[]) } + | ifaceimps ';' ifacedecls { ($1,$3) } + | ifacedecls { ([],$1) } + +ifaceimps :: { [(Module, IsBootInterface)] } -- Reversed, but that's ok + : ifaceimps ';' ifaceimp { $3 : $1 } + | ifaceimp { [$1] } + +ifaceimp :: { (Module, IsBootInterface) } + : 'import' maybe_src modid { (unLoc $3, $2) } + +-- The defn of iface decls allows a trailing ';', which the lexer geneates for +-- module Foo where +-- foo :: () +ifacedecls :: { [HsDecl RdrName] } -- Reversed, but doesn't matter + : ifacedecls ';' ifacedecl { $3 : $1 } + | ifacedecls ';' { $1 } | ifacedecl { [$1] } - | {- empty -} { [] } ifacedecl :: { HsDecl RdrName } : var '::' sigtype diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 236d538..d9151a8 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -50,8 +50,9 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType +import Packages ( PackageIdH(..) ) import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache, - IfacePackage(..) ) + Dependencies(..), IsBootInterface, noDependencies ) import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, @@ -206,13 +207,14 @@ to get hi-boot files right! \begin{code} -mkBootIface :: Module -> [HsDecl RdrName] -> ModIface +mkBootIface :: Module -> ([(Module, IsBootInterface)], [HsDecl RdrName]) -> ModIface -- Make the ModIface for a hi-boot file -- The decls are of very limited form -- The package will be filled in later (see LoadIface.readIface) -mkBootIface mod decls - = (emptyModIface ThisPackage{-fill in later-} mod) { +mkBootIface mod (imports, decls) + = (emptyModIface HomePackage{-fill in later-} mod) { mi_boot = True, + mi_deps = noDependencies { dep_mods = imports }, mi_exports = [(mod, map mk_export decls')], mi_decls = decls_w_vers, mi_ver_fn = mkIfaceVerCache decls_w_vers } @@ -320,7 +322,7 @@ hsStrictMark HsStrict = MarkedStrict hsStrictMark HsUnbox = MarkedUnboxed hsIfaceName rdr_name -- Qualify unqualifed occurrences - -- with the module name + -- with the module name | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 5b426fe..8ae1e53 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -38,9 +38,9 @@ import HscTypes ( GenAvailInfo(..), AvailInfo, GhciMode(..), IfaceExport, HomePackageTable, PackageIfaceTable, availNames, unQualInScope, Deprecs(..), ModIface(..), Dependencies(..), - lookupIface, ExternalPackageState(..), - IfacePackage(..) + lookupIface, ExternalPackageState(..) ) +import Packages ( PackageIdH(..) ) import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, @@ -199,7 +199,7 @@ importsFromImportDecl this_mod (dependent_mods, dependent_pkgs) = case mi_package iface of - ThisPackage -> + HomePackage -> -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged @@ -213,7 +213,7 @@ importsFromImportDecl this_mod -- check. See LoadIface.loadHiBootInterface ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) - ExternalPackage pkg -> + ExtPackage pkg -> -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index ec8ed27..7593adb 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -15,11 +15,12 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), import CoreSyn import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), - ModDetails(..), HomeModInfo(..), hscEPS ) + ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ), + hscEPS, hptRules ) import CSE ( cseProgram ) import Rules ( RuleBase, ruleBaseIds, emptyRuleBase, extendRuleBaseList, pprRuleBase, ruleCheckProgram ) -import Module ( moduleEnvElts ) +import Module ( elemModuleEnv, lookupModuleEnv ) import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) import CoreUtils ( coreBindsSize ) @@ -48,7 +49,7 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable import List ( partition ) -import Maybes ( orElse ) +import Maybes ( orElse, fromJust ) \end{code} %************************************************************************ @@ -214,7 +215,7 @@ prepareRules :: HscEnv -- (b) Rules are now just orphan rules prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) - guts@(ModGuts { mg_binds = binds, mg_rules = local_rules }) + guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules }) us = do { eps <- hscEPS hsc_env @@ -223,6 +224,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) env = setInScopeSet gentleSimplEnv local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) + home_pkg_rules = hptRules hsc_env (dep_mods deps) (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules -- Get the rules for locally-defined Ids out of the RuleBase @@ -239,7 +241,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) -- rules for Ids in this module; if there is, the above bad things may happen pkg_rule_base = eps_rule_base eps - hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) + hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules -- Update the binders in the local bindings with the lcoal rules @@ -273,8 +275,6 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) #endif ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules }) } - where - add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info)) updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] updateBinders rule_base binds diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 2835c85..4fb3f87 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -23,7 +23,7 @@ module Inst ( instLoc, getDictClassTys, dictPred, lookupInst, LookupInstResult(..), - tcExtendLocalInstEnv, tcGetInstEnvs, + tcExtendLocalInstEnv, tcGetInstEnvs, isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -71,7 +71,8 @@ import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSub import Unify ( tcMatchTys ) import Kind ( isSubKind ) import Packages ( isHomeModule ) -import HscTypes ( ExternalPackageState(..) ) +import HscTypes ( HscEnv( hsc_HPT ), ExternalPackageState(..), + ModDetails( md_insts ), HomeModInfo( hm_details ) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName ) import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) @@ -83,13 +84,14 @@ import Literal ( inIntRange ) import Var ( TyVar, tyVarKind, setIdType ) import VarEnv ( TidyEnv, emptyTidyEnv ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) +import Module ( moduleEnvElts, elemModuleEnv, lookupModuleEnv ) import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) import CmdLineOpts( DynFlags ) -import Maybes ( isJust ) +import Maybes ( isJust, fromJust ) import Outputable \end{code} @@ -615,6 +617,7 @@ addDictLoc dfun thing_inside where loc = getSrcLoc dfun \end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 2f64d4c..5ebfe58 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -48,11 +48,11 @@ module TcEnv( import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds ) import TcIface ( tcImportDecl ) import TcRnMonad -import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) +import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, - tidyOpenType, tidyOpenTyVar, pprTyThingCategory + tidyOpenType, pprTyThingCategory ) import qualified Type ( getTyVar_maybe ) import Id ( idName, isLocalId ) @@ -105,8 +105,7 @@ tcLookupGlobal name { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of Just thing -> return thing - Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) - ; initIfaceTcRn (tcImportDecl name) } + Nothing -> tcImportDecl name }} \end{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 1f270c3..cda838a 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -37,6 +37,7 @@ import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) +import InstEnv ( extendInstEnvList ) import TcBinds ( tcTopBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv ) @@ -57,7 +58,7 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( mkModule, moduleEnvElts ) +import Module ( Module, ModuleEnv, mkModule, moduleEnvElts ) import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet @@ -65,10 +66,10 @@ import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), noDependencies, + GhciMode(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, + TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, emptyFixityEnv ) @@ -168,12 +169,19 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies -- Record boot-file info in the EPS, so that it's -- visible to loadHiBootInterface in tcRnSrcDecls, -- and any other incrementally-performed imports - updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ; + let { dep_mods :: ModuleEnv (Module, IsBootInterface) + ; dep_mods = imp_dep_mods imports } ; + + updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; -- Update the gbl env - updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports }) - $ do { + let { home_insts = hptInstances hsc_env (moduleEnvElts dep_mods) } ; + updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = rdr_env, + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_imports = tcg_imports gbl `plusImportAvails` imports }) + $ do { + traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; -- Fail if there are any errors so far -- The error printing (if needed) takes advantage @@ -281,7 +289,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) setGblEnv tcg_env $ do { -- Now the core bindings - core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; + core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; -- Wrap up let { diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 88a2e69..aeca508 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -14,16 +14,15 @@ import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), TyThing, TypeEnv, emptyTypeEnv, ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import Module ( Module, unitModuleEnv, foldModuleEnv ) +import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) import Type ( Type ) import NameEnv ( extendNameEnvList ) -import InstEnv ( InstEnv, emptyInstEnv, extendInstEnvList ) +import InstEnv ( emptyInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) @@ -85,7 +84,7 @@ initTc hsc_env mod do_this tcg_default = Nothing, tcg_type_env = emptyNameEnv, tcg_type_env_var = type_env_var, - tcg_inst_env = mkHomePackageInstEnv hsc_env, + tcg_inst_env = emptyInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, tcg_exports = emptyNameSet, @@ -145,16 +144,6 @@ initTcPrintErrors env mod todo = do printErrorsAndWarnings msgs return res -mkHomePackageInstEnv :: HscEnv -> InstEnv --- At the moment we (wrongly) build an instance environment from all the --- home-package modules we have already compiled. --- We should really only get instances from modules below us in the --- module import tree. -mkHomePackageInstEnv (HscEnv {hsc_HPT = hpt}) - = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt - where - add dfuns inst_env = extendInstEnvList inst_env dfuns - -- mkImpTypeEnv makes the imported symbol table mkImpTypeEnv :: ExternalPackageState -> HomePackageTable -> Name -> Maybe TyThing @@ -836,11 +825,16 @@ setLocalRdrEnv rdr_env thing_inside %************************************************************************ \begin{code} +mkIfLclEnv :: Module -> SDoc -> IfLclEnv +mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, + if_loc = loc, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } + initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv - ; let { if_env = IfGblEnv { - if_rec_types = Just (tcg_mod tcg_env, get_type_env) } + ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) } ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -848,11 +842,10 @@ initIfaceExtCore :: IfL a -> TcRn a initIfaceExtCore thing_inside = do { tcg_env <- getGblEnv ; let { mod = tcg_mod tcg_env + ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod) ; if_env = IfGblEnv { if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } - ; if_lenv = IfLclEnv { if_mod = mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + ; if_lenv = mkIfLclEnv mod doc } ; setEnvs (if_env, if_lenv) thing_inside } @@ -860,8 +853,7 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface -- Initialise the environment with no useful info at all initIfaceCheck hsc_env do_this - = do { let { gbl_env = IfGblEnv { if_rec_types = Nothing } ; - } + = do { let gbl_env = IfGblEnv { if_rec_types = Nothing } ; initTcRnIf 'i' hsc_env gbl_env () do_this } @@ -872,14 +864,13 @@ initIfaceTc :: HscEnv -> ModIface initIfaceTc hsc_env iface do_this = do { tc_env_var <- newIORef emptyTypeEnv ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; - ; if_lenv = IfLclEnv { if_mod = mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + ; if_lenv = mkIfLclEnv mod doc } ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) } where mod = mi_module iface + doc = ptext SLIT("The interface for") <+> quotes (ppr mod) initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore @@ -894,13 +885,23 @@ initIfaceRules hsc_env guts do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceLcl :: Module -> IfL a -> IfM lcl a -initIfaceLcl mod thing_inside - = setLclEnv (IfLclEnv { if_mod = mod, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv }) - thing_inside +initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a +initIfaceLcl mod loc_doc thing_inside + = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside + +getIfModule :: IfL Module +getIfModule = do { env <- getLclEnv; return (if_mod env) } +-------------------- +failIfM :: Message -> IfL a +-- The Iface monad doesn't have a place to accumulate errors, so we +-- just fall over fast if one happens; it "shouldnt happen". +-- We use IfL here so that we can get context info out of the local env +failIfM msg + = do { env <- getLclEnv + ; let full_msg = if_loc env $$ nest 2 msg + ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) + ; failM } -------------------- forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index f01df31..5fcd47b 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -9,7 +9,7 @@ module TcRnTypes( -- The environment types Env(..), TcGblEnv(..), TcLclEnv(..), - IfGblEnv(..), IfLclEnv(..), + IfGblEnv(..), IfLclEnv(..), -- Ranamer types ErrCtxt, @@ -232,6 +232,13 @@ data IfLclEnv -- it means M.f = \x -> x, where M is the if_mod if_mod :: Module, + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings if_id_env :: OccEnv Id -- Nested id binding } diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 982ac91..b51bfdc 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -510,8 +510,7 @@ tcLookupTh name { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of Just thing -> return (AGlobal thing) - Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) - ; thing <- initIfaceTcRn (tcImportDecl name) + Nothing -> do { thing <- tcImportDecl name ; return (AGlobal thing) } -- Imported names should always be findable; -- if not, we fail hard in tcImportDecl diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 90c7e53..962531f 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -56,6 +56,7 @@ import Unique import Panic import UniqFM import FastMutInt +import PackageConfig ( PackageId, packageIdFS, fsToPackageId ) #if __GLASGOW_HASKELL__ < 503 import DATA_IOREF @@ -749,6 +750,10 @@ getFS bh = do (BA ba) <- getByteArray bh (I# l) return $! (mkFastSubStringBA# ba 0# l) +instance Binary PackageId where + put_ bh pid = put_ bh (packageIdFS pid) + get bh = do { fs <- get bh; return (fsToPackageId fs) } + instance Binary FastString where put_ bh f@(FastString id l ba) = case getUserData bh of { diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index c8345fb..5592b55 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -55,6 +55,7 @@ import {-# SOURCE #-} Module( Module ) import {-# SOURCE #-} OccName( OccName ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) +import PackageConfig ( PackageId, packageIdString ) import FastString import qualified Pretty import Pretty ( Doc, Mode(..) ) @@ -356,6 +357,9 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) => instance Outputable FastString where ppr fs = text (unpackFS fs) -- Prints an unadorned string, -- no double quotes or anything + +instance Outputable PackageId where + ppr pid = text (packageIdString pid) \end{code}