From: simonmar Date: Thu, 24 Mar 2005 16:14:11 +0000 (+0000) Subject: [project @ 2005-03-24 16:14:00 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~861 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=19519dc35bad5649226a9f7015eaabb154722e54 [project @ 2005-03-24 16:14:00 by simonmar] Cleanup the upsweep strategy in GHC.load. Now it's hopefully clearer how we decide what modules to recompile, and which are "stable" (not even looked at) during a reload. See the comments for details. Also, I've taken some trouble to explicitly prune out things that aren't required before a reload, which should reduce the memory requirements for :reload in GHCi. Currently I believe it keeps most of the old program until the reload is complete, now it shouldn't require any extra memory. --- diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 6db6b45..4ee87cd 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2005 % -- -------------------------------------- @@ -30,7 +30,7 @@ import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages import DriverPhases ( isObjectFilename, isDynLibFilename ) import Util ( getFileSuffix ) -import Finder ( findModule, findLinkable, FindResult(..) ) +import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv @@ -54,6 +54,7 @@ import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) import Control.Exception ( block, throwDyn ) +import Maybe ( isJust, fromJust ) #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -400,7 +401,8 @@ getLinkDeps hsc_env hpt pit mods get_linkable mod_name -- A home-package module | Just mod_info <- lookupModuleEnv hpt mod_name - = return (hm_linkable mod_info) + = ASSERT(isJust (hm_linkable mod_info)) + return (fromJust (hm_linkable mod_info)) | otherwise = -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -412,7 +414,7 @@ getLinkDeps hsc_env hpt pit mods found loc mod_name = do { -- ...and then find the linkable for it - mb_lnk <- findLinkable mod_name loc ; + mb_lnk <- findObjectLinkableMaybe mod_name loc ; case mb_lnk of { Nothing -> no_obj mod_name ; Just lnk -> return lnk diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index f9fdafa..a4bf3cc 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -87,27 +87,28 @@ preprocess dflags filename = compile :: HscEnv -> ModSummary - -> Bool -- True <=> source unchanged - -> Bool -- True <=> have object + -> Maybe Linkable -- Just linkable <=> source unchanged -> Maybe ModIface -- Old interface, if available -> IO CompResult data CompResult - = CompOK ModDetails -- New details - ModIface -- New iface - (Maybe Linkable) -- New code; Nothing => compilation was not reqd - -- (old code is still valid) + = CompOK ModDetails -- New details + ModIface -- New iface + (Maybe Linkable) -- a Maybe, for the same reasons as hm_linkable | CompErrs -compile hsc_env mod_summary - source_unchanged have_object old_iface = do +compile hsc_env mod_summary maybe_old_linkable old_iface = do let dflags0 = hsc_dflags hsc_env this_mod = ms_mod mod_summary src_flavour = ms_hsc_src mod_summary + have_object + | Just l <- maybe_old_linkable, isObjectLinkable l = True + | otherwise = False + showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary) let verb = verbosity dflags0 @@ -149,17 +150,19 @@ compile hsc_env mod_summary -- -no-recomp should also work with --make let do_recomp = dopt Opt_RecompChecking dflags - source_unchanged' = source_unchanged && do_recomp + source_unchanged = isJust maybe_old_linkable && do_recomp hsc_env' = hsc_env { hsc_dflags = dflags' } -- run the compiler hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary - source_unchanged' have_object old_iface + source_unchanged have_object old_iface case hsc_result of HscFail -> return CompErrs - HscNoRecomp details iface -> return (CompOK details iface Nothing) + HscNoRecomp details iface -> + ASSERT(isJust maybe_old_linkable) + return (CompOK details iface maybe_old_linkable) HscRecomp details iface stub_h_exists stub_c_exists maybe_interpreted_code @@ -254,7 +257,7 @@ link BatchCompile dflags batch_attempt_linking hpt pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos -- the linkables to link - linkables = map hm_linkable home_mod_infos + linkables = map (fromJust.hm_linkable) home_mod_infos when (verb >= 3) $ do hPutStrLn stderr "link: linkables are ..." diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index c8896f8..778f06d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -13,7 +13,8 @@ module Finder ( mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () - findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + findObjectLinkableMaybe, + findObjectLinkable, cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc ) where @@ -37,6 +38,7 @@ import System.IO import Control.Monad import Maybes ( MaybeErr(..) ) import Data.Maybe ( isNothing ) +import Time ( ClockTime ) type FileExt = String -- Filename extension @@ -391,20 +393,24 @@ mkHiPath dflags basename mod_basename -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it -findLinkable :: Module -> ModLocation -> IO (Maybe Linkable) -findLinkable mod locn +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - obj_exist <- doesFileExist obj_fn - if not obj_exist - then return Nothing - else - do let stub_fn = case splitFilename3 obj_fn of - (dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o" - stub_exist <- doesFileExist stub_fn - obj_time <- getModificationTime obj_fn - if stub_exist - then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) - else return (Just (LM obj_time mod [DotO obj_fn])) + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = do + let stub_fn = case splitFilename3 obj_fn of + (dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o" + stub_exist <- doesFileExist stub_fn + if stub_exist + then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) + else return (LM obj_time mod [DotO obj_fn]) -- ----------------------------------------------------------------------------- -- Utils diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 8cf3c24..52476e1 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -126,10 +126,12 @@ import BasicTypes ( SuccessFlag(..), succeeded ) import Maybes ( orElse, expectJust, mapCatMaybes ) import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, fromJust ) +import Maybe ( isJust, isNothing, fromJust ) +import Maybes ( expectJust ) import List ( partition, nub ) import Monad ( unless, when, foldM ) import System ( exitWith, ExitCode(..) ) +import Time ( ClockTime ) import EXCEPTION as Exception hiding (handle) import DATA_IOREF import IO @@ -372,59 +374,30 @@ load s@(Session ref) maybe_mod{-ToDo-} let mg2_with_srcimps :: [SCC ModSummary] mg2_with_srcimps = topSortModuleGraph True mod_graph - -- Sort out which linkables we wish to keep in the unlinked image. - -- See getValidLinkables below for details. - (valid_old_linkables, new_linkables) - <- getValidLinkables ghci_mode (hptLinkables hpt1) - all_home_mods mg2_with_srcimps - - -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - - -- The new_linkables are .o files we found on the disk, presumably - -- as a result of a GHC run "on the side". So we'd better forget - -- everything we know abouut those modules! - let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables) - - -- When (verb >= 2) $ - -- putStrLn (showSDoc (text "Valid linkables:" - -- <+> ppr valid_linkables)) - - -- Figure out a stable set of modules which can be retained - -- the top level envs, to avoid upsweeping them. Goes to a - -- bit of trouble to avoid upsweeping module cycles. - -- - -- Construct a set S of stable modules like this: - -- Travel upwards, over the sccified graph. For each scc - -- of modules ms, add ms to S only if: - -- 1. All home imports of ms are either in ms or S - -- 2. A valid old linkable exists for each module in ms - - -- mg2_with_srcimps has no hi-boot nodes, - -- and hence neither does stable_mods - stable_summaries <- preUpsweep valid_old_linkables - all_home_mods [] mg2_with_srcimps - let stable_mods = map ms_mod stable_summaries - stable_linkables = filter (\m -> linkableModule m `elem` stable_mods) - valid_old_linkables - - stable_hpt = filterModuleEnv is_stable_hm hpt1 - is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods - - upsweep_these - = filter (\scc -> any (`notElem` stable_mods) - (map ms_mod (flattenSCC scc))) - mg2 - - when (verb >= 2) $ - hPutStrLn stderr (showSDoc (text "Stable modules:" - <+> sep (map (text.moduleUserString) stable_mods))) + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + | BatchCompile <- ghci_mode = ([],[]) + | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + evaluate pruned_hpt + + when (verb >= 2) $ + putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco)) -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupModuleEnv pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] unload hsc_env stable_linkables - -- We can now glom together our linkable sets - let valid_linkables = valid_old_linkables ++ new_linkables - -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better -- to let upsweep_mods do this, so at least some useful work gets @@ -439,22 +412,15 @@ load s@(Session ref) maybe_mod{-ToDo-} let cleanup = cleanTempFilesExcept dflags (ppFilesFromSummaries (flattenSCCs mg2)) - (upsweep_ok, hsc_env3, modsUpswept) - <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt }) - (old_hpt, valid_linkables) - cleanup upsweep_these - - -- At this point, modsUpswept and newLis should have the same - -- length, so there is one new (or old) linkable for each - -- mod which was processed (passed to compile). + (upsweep_ok, hsc_env1, modsUpswept) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) + pruned_hpt stable_mods cleanup mg2 -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. - -- (NOT STRICTLY TRUE if an interactive session was started - -- with some object on disk ???) -- Get in in a roughly top .. bottom order (hence reverse). - let modsDone = reverse modsUpswept ++ stable_summaries + let modsDone = reverse modsUpswept -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. @@ -492,9 +458,9 @@ load s@(Session ref) maybe_mod{-ToDo-} "because there is no " ++ main_mod ++ " module.") -- link everything together - linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3) + linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) - let hsc_env4 = hsc_env3{ hsc_mod_graph = modsDone } + let hsc_env4 = hsc_env1{ hsc_mod_graph = modsDone } loadFinish Succeeded linkresult ref hsc_env4 else @@ -514,15 +480,19 @@ load s@(Session ref) maybe_mod{-ToDo-} modsDone let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) - (hsc_HPT hsc_env3) + (hsc_HPT hsc_env1) -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (moduleEnvElts (hsc_HPT hsc_env))) do + -- Link everything together linkresult <- link ghci_mode dflags False hpt4 - let hsc_env4 = hsc_env3{ hsc_mod_graph = mods_to_keep, + let hsc_env4 = hsc_env1{ hsc_mod_graph = mods_to_keep, hsc_HPT = hpt4 } loadFinish Failed linkresult ref hsc_env4 @@ -540,6 +510,7 @@ loadFinish all_ok Succeeded ref hsc_env = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } return all_ok + -- Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env @@ -565,206 +536,156 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' Interactive -> panic "unload: no interpreter" #endif other -> panic "unload: strange mode" - ------------------------------------------------------------------------------ --- getValidLinkables --- For each module (or SCC of modules), we take: --- --- - an on-disk linkable, if this is the first time around and one --- is available. --- --- - the old linkable, otherwise (and if one is available). --- --- and we throw away the linkable if it is older than the source file. --- In interactive mode, we also ignore the on-disk linkables unless --- all of the dependents of this SCC also have on-disk linkables (we --- can't have dynamically loaded objects that depend on interpreted --- modules in GHCi). --- --- If a module has a valid linkable, then it may be STABLE (see below), --- and it is classified as SOURCE UNCHANGED for the purposes of calling --- compile. --- --- ToDo: this pass could be merged with the preUpsweep. --- --- **************** --- CAREFUL! This pass operates on the cyclic version of --- the module graph (topSortModuleGraph True), whereas the upsweep operates on --- the non-cyclic (topSortModuleGraph False) version of the graph. --- **************** - -getValidLinkables - :: GhcMode - -> [Linkable] -- old linkables - -> [Module] -- all home modules - -> [SCC ModSummary] -- all modules in the program, dependency order - -> IO ( [Linkable], -- still-valid linkables - [Linkable] -- new linkables we just found on the disk - -- presumably generated by separate run of ghc - ) - -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 - | b = partition_it ls valid (l:new) - | otherwise = partition_it ls (l:valid) new - - -getValidLinkablesSCC - :: GhcMode - -> [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 - scc_names = map ms_mod scc - home_module m = m `elem` all_home_mods && m `notElem` scc_names - scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc)) - -- NB. ms_imps, not ms_allimps above. We don't want to - -- force a module's SOURCE imports to be already compiled for - -- its object linkable to be valid. - - -- 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 == BatchCompile || all has_object scc_allhomeimps - in do - - new_linkables' - <- foldM (getValidLinkable old_linkables objects_allowed) [] scc - - -- since an scc can contain only all objects or no objects at all, - -- we have to check whether we got all objects or not, and re-do - -- the linkable check if not. - new_linkables' <- - if objects_allowed - && not (all isObjectLinkable (map fst new_linkables')) - then foldM (getValidLinkable old_linkables False) [] scc - else return new_linkables' - - return (new_linkables ++ new_linkables') - - -getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary - -> IO [(Linkable,Bool)] - -- True <=> linkable is new; i.e. freshly discovered on the disk - -- presumably generated 'on the side' - -- by a separate GHC run -getValidLinkable old_linkables objects_allowed new_linkables summary - -- 'objects_allowed' says whether we permit this module to - -- have a .o-file linkable. We only permit it if all the - -- modules it depends on also have .o files; a .o file can't - -- link to a bytecode module - = do let mod_name = ms_mod summary - - maybe_disk_linkable - <- if (not objects_allowed) - then return Nothing - - else findLinkable mod_name (ms_location summary) - - let old_linkable = findModuleLinkable_maybe old_linkables mod_name - - new_linkables' = - case (old_linkable, maybe_disk_linkable) of - (Nothing, Nothing) -> [] - - -- new object linkable just appeared - (Nothing, Just l) -> up_to_date l True - - (Just l, Nothing) - | isObjectLinkable l -> [] - -- object linkable disappeared! In case we need to - -- relink the module, disregard the old linkable and - -- just interpret the module from now on. - | otherwise -> up_to_date l False - -- old byte code linkable - - (Just l, Just l') - | not (isObjectLinkable l) -> up_to_date l False - -- if the previous linkable was interpreted, then we - -- ignore a newly compiled version, because the version - -- numbers in the interface file will be out-of-sync with - -- our internal ones. - | linkableTime l' > linkableTime l -> up_to_date l' True - | linkableTime l' == linkableTime l -> up_to_date l False - | otherwise -> [] - -- on-disk linkable has been replaced by an older one! - -- again, disregard the previous one. - - up_to_date l b - | linkableTime l < ms_hs_date summary = [] - | otherwise = [(l,b)] - -- why '<' rather than '<=' above? If the filesystem stores +-- ----------------------------------------------------------------------------- +-- checkStability + +{- + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + NB. stability is of no importance to BatchCompile at all, only Interactive. + (ToDo: what about JustTypecheck?) + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + + ------------------- + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) + ------------------- + + These properties embody the following ideas: + + - if a module is stable: + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a ModDetails. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the upsweep. + All non-stable modules can (and should) therefore be unlinked + before the upsweep. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [Module] -- all home modules + -> ([Module], -- stableObject + [Module]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of + Nothing -> True + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + -- why '>=' rather than '>' above? If the filesystem stores -- times to the nearset second, we may occasionally find that -- the object & source have the same modification time, -- especially if the source was automatically generated -- and compiled. Using >= is slightly unsafe, but it matches -- make's behaviour. - return (new_linkables' ++ new_linkables) + bco_ok ms + = case lookupModuleEnv hpt (ms_mod ms) of + Nothing -> False + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms +ms_allimps :: ModSummary -> [Module] +ms_allimps ms = ms_srcimps ms ++ ms_imps ms -hptLinkables :: HomePackageTable -> [Linkable] --- Get all the linkables from the home package table, one for each module --- Once the HPT is up to date, these are the ones we should link -hptLinkables hpt = map hm_linkable (moduleEnvElts hpt) +-- ----------------------------------------------------------------------------- +-- Prune the HomePackageTable +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([Module],[Module]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapModuleEnv prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = mi_module (hm_iface hmi) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupModuleEnv ms_map modl) ------------------------------------------------------------------------------ --- Do a pre-upsweep without use of "compile", to establish a --- (downward-closed) set of stable modules for which we won't call compile. - --- a stable module: --- * has a valid linkable (see getValidLinkables above) --- * depends only on stable modules --- * has an interface in the HPT (interactive mode only) - -preUpsweep :: [Linkable] -- new valid linkables - -> [Module] -- names of all mods encountered in downsweep - -> [ModSummary] -- accumulating stable modules - -> [SCC ModSummary] -- scc-ified mod graph, including src imps - -> IO [ModSummary] -- stable modules - -preUpsweep valid_lis all_home_mods stable [] = return stable -preUpsweep valid_lis all_home_mods stable (scc0:sccs) - = do let scc = flattenSCC scc0 - scc_allhomeimps :: [Module] - scc_allhomeimps - = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc)) - all_imports_in_scc_or_stable - = all in_stable_or_scc scc_allhomeimps - 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 scc_mod - = isJust (findModuleLinkable_maybe valid_lis scc_mod) - - scc_is_stable = all_imports_in_scc_or_stable - && all has_valid_linkable scc_mods - - if scc_is_stable - then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs - else preUpsweep valid_lis all_home_mods stable sccs + ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ] -ms_allimps :: ModSummary -> [Module] -ms_allimps ms = ms_srcimps ms ++ ms_imps ms + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. @@ -786,33 +707,40 @@ findPartiallyCompletedCycles modsDone theGraph then mods_in_this_cycle ++ chewed_rest else chewed_rest +-- ----------------------------------------------------------------------------- +-- The upsweep + +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. --- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. -upsweep_mods :: HscEnv -- Includes initially-empty HPT - -> (HomePackageTable, [Linkable]) -- HPT and valid linkables from last time round - -> IO () -- How to clean up unwanted tmp files - -> [SCC ModSummary] -- Mods to do (the worklist) - -> IO (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep_mods hsc_env oldUI cleanup + +upsweep + :: HscEnv -- Includes initially-empty HPT + -> HomePackageTable -- HPT from last time round (pruned) + -> ([Module],[Module]) -- stable modules (see checkStability) + -> IO () -- How to clean up unwanted tmp files + -> [SCC ModSummary] -- Mods to do (the worklist) + -> IO (SuccessFlag, + HscEnv, -- With an updated HPT + [ModSummary]) -- Mods which succeeded + +upsweep hsc_env old_hpt stable_mods cleanup [] = return (Succeeded, hsc_env, []) -upsweep_mods hsc_env oldUI cleanup +upsweep hsc_env old_hpt stable_mods cleanup (CyclicSCC ms:_) = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup +upsweep hsc_env old_hpt stable_mods cleanup (AcyclicSCC mod:mods) = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - mb_mod_info <- upsweep_mod hsc_env oldUI mod + mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod cleanup -- Remove unwanted tmp files between compilations @@ -822,36 +750,97 @@ upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup { let this_mod = ms_mod mod -- Add new info to hsc_env - hpt1 = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info + hpt1 = extendModuleEnv (hsc_HPT hsc_env) + this_mod mod_info hsc_env1 = hsc_env { hsc_HPT = hpt1 } - -- Space-saving: delete the old HPT entry and - -- linkable for mod BUT if mod is a hs-boot - -- node, don't delete it For the linkable this - -- is dead right: the linkable relates only to - -- the main Haskell source file. For the + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the -- interface, the HPT entry is probaby for the -- main Haskell source file. Deleting it -- would force .. (what?? --SDM) - oldUI1 | isBootSummary mod = oldUI - | otherwise - = (delModuleEnv old_hpt this_mod, - delModuleLinkable old_linkables this_mod) + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delModuleEnv old_hpt this_mod - ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods - ; return (restOK, hsc_env2, mod:modOKs) } + ; (restOK, hsc_env2, modOKs) + <- upsweep hsc_env1 old_hpt1 stable_mods cleanup mods + ; return (restOK, hsc_env2, mod:modOKs) + } -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv - -> (HomePackageTable, UnlinkedImage) + -> HomePackageTable + -> ([Module],[Module]) -> ModSummary -> IO (Maybe HomeModInfo) -- Nothing => Failed -upsweep_mod hsc_env (old_hpt, old_linkables) summary +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary = do - let this_mod = ms_mod summary - + let + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) + compile_it = upsweep_compile hsc_env old_hpt this_mod summary + + case ghcMode (hsc_dflags hsc_env) of + BatchCompile -> + case () of + -- Batch-compilating is easy: just check whether we have + -- an up-to-date object file. If we do, then the compiler + -- needs to do a recompilation check. + _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do + linkable <- + findObjectLinkable this_mod obj_fn obj_date + compile_it (Just linkable) + + | otherwise -> + compile_it Nothing + + interactive -> + case () of + _ | is_stable_obj, isJust old_hmi -> + return old_hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + linkable <- + findObjectLinkable this_mod obj_fn + (expectJust "upseep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | is_stable_bco -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + return old_hmi + -- BCO is stable: nothing to do + + | Just hmi <- old_hmi, + Just l <- hm_linkable hmi, not (isObjectLinkable l), + linkableTime l >= ms_hs_date summary -> + compile_it (Just l) + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + | otherwise -> + compile_it Nothing + -- no existing code at all: we must recompile. + where + is_stable_obj = this_mod `elem` stable_obj + is_stable_bco = this_mod `elem` stable_bco + + old_hmi = lookupModuleEnv old_hpt this_mod + +-- Run hsc to compile a module +upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do + let -- The old interface is ok if it's in the old HPT -- a) we're compiling a source file, and the old HPT -- entry is for a source file @@ -861,7 +850,7 @@ upsweep_mod hsc_env (old_hpt, old_linkables) summary -- manager, but that does no harm. Otherwise the hs-boot file -- will always be recompiled - mb_old_iface + mb_old_iface = case lookupModuleEnv old_hpt this_mod of Nothing -> Nothing Just hm_info | isBootSummary summary -> Just iface @@ -870,37 +859,26 @@ upsweep_mod hsc_env (old_hpt, old_linkables) summary where iface = hm_iface hm_info - maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod - source_unchanged = isJust maybe_old_linkable - - old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable + compresult <- compile hsc_env summary mb_old_linkable mb_old_iface - have_object - | Just l <- maybe_old_linkable, isObjectLinkable l = True - | otherwise = False + case compresult of + -- Compilation failed. Compile may still have updated the PCS, tho. + CompErrs -> return Nothing - compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface - - case compresult of - - -- Compilation "succeeded", and may or may not have returned a new - -- linkable (depending on whether compilation was actually performed - -- or not). - CompOK new_details new_iface maybe_new_linkable - -> do let - new_linkable = maybe_new_linkable `orElse` old_linkable - new_info = HomeModInfo { hm_iface = new_iface, + -- Compilation "succeeded", and may or may not have returned a new + -- linkable (depending on whether compilation was actually performed + -- or not). + CompOK new_details new_iface new_linkable + -> do let new_info = HomeModInfo { hm_iface = new_iface, hm_details = new_details, hm_linkable = new_linkable } return (Just new_info) - -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return Nothing -- Filter modules in the HPT retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt - = mkModuleEnv [ (mod, fromJust mb_mod_info) + = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info) | mod <- keep_these , let mb_mod_info = lookupModuleEnv hpt mod , isJust mb_mod_info ] @@ -932,7 +910,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)), + nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), out_edge_keys hs_boot_key (ms_srcimps s) ++ out_edge_keys HsSrcFile (ms_imps s) ) | s <- summaries @@ -1013,7 +991,6 @@ downsweep hsc_env old_summaries excl_mods loop (concatMap msDeps rootSummaries) (mkNodeMap rootSummaries) where - dflags = hsc_dflags hsc_env roots = hsc_targets hsc_env old_summary_map :: NodeMap ModSummary @@ -1044,7 +1021,7 @@ downsweep hsc_env old_summaries excl_mods many -> multiRootsErr modl many where modl = ms_mod summ dups = - [ fromJust (ml_hs_file (ms_location summ')) + [ expectJust "checkDup" (ml_hs_file (ms_location summ')) | summ' <- summaries, ms_mod summ' == modl ] loop :: [(FilePath,Module,IsBootInterface)] @@ -1122,12 +1099,15 @@ summariseFile hsc_env file addHomeModuleToFinder hsc_env mod location src_timestamp <- getModificationTime file + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, ms_hspp_file = Just hspp_fn, ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, - ms_hs_date = src_timestamp }) + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) -- Summarise a module, and pick up source and timestamp. summarise :: HscEnv @@ -1143,71 +1123,82 @@ summarise hsc_env old_summary_map cur_mod is_boot wanted_mod excl_mods = return Nothing | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) - = do { -- Find its new timestamp; all the + = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = fromJust (ml_hs_file location) - - ; src_timestamp <- getModificationTime src_fn + let location = ms_location old_summary + src_fn = expectJust "summarise" (ml_hs_file location) -- return the cached summary if the source didn't change - ; if ms_hs_date old_summary == src_timestamp - then return (Just old_summary) - else new_summary location - } + src_timestamp <- getModificationTime src_fn + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location is_boot + return (Just old_summary{ ms_obj_date = obj_timestamp }) + else + -- source changed: re-summarise + new_summary location src_fn src_timestamp | otherwise - = do { found <- findModule hsc_env wanted_mod True {-explicit-} - ; case found of + = do found <- findModule hsc_env wanted_mod True {-explicit-} + case found of Found location pkg - | not (isHomePackage pkg) -> return Nothing + | not (isHomePackage pkg) -> return Nothing -- Drop external-pkg - | isJust (ml_hs_file location) -> new_summary location + | isJust (ml_hs_file location) -> just_found location -- Home package err -> noModError dflags cur_mod wanted_mod err -- Not found - } where dflags = hsc_dflags hsc_env hsc_src = if is_boot then HsBootFile else HsSrcFile - new_summary location - = do { -- Adjust location to point to the hs-boot source file, + just_found location = do + -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = fromJust (ml_hs_file location') + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') -- Check that it exists - -- It might have been deleted since the Finder last found it - ; exists <- doesFileExist src_fn - ; if exists then return () else noHsFileErr cur_mod src_fn + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr cur_mod src_fn + Just t -> new_summary location' src_fn t + + new_summary location src_fn src_timestamp + = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - ; (dflags', hspp_fn) <- preprocess dflags src_fn - ; buf <- hGetStringBuffer hspp_fn - ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn + (dflags', hspp_fn) <- preprocess dflags src_fn + buf <- hGetStringBuffer hspp_fn + (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn - ; when (mod_name /= wanted_mod) $ + when (mod_name /= wanted_mod) $ throwDyn (ProgramError (showSDoc (text src_fn <> text ": file name does not match module name" <+> quotes (ppr mod_name)))) - -- Find its timestamp, and return the summary - ; src_timestamp <- getModificationTime src_fn - ; return (Just ( ModSummary { ms_mod = wanted_mod, - ms_hsc_src = hsc_src, - ms_location = location', - ms_hspp_file = Just hspp_fn, - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp })) - } + -- Find the object timestamp, and return the summary + obj_timestamp <- getObjTimestamp location is_boot + + return (Just ( ModSummary { ms_mod = wanted_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = Just hspp_fn, + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) ----------------------------------------------------------------------------- -- Error messages @@ -1358,7 +1349,6 @@ setContext (Session ref) toplevs exports = do hsc_env <- readIORef ref let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env mapM_ (checkModuleExists hsc_env hpt) exports export_env <- mkExportEnv hsc_env exports @@ -1561,6 +1551,6 @@ showModule s mod_summary = withSession s $ \hsc_env -> do Nothing -> panic "missing linkable" Just mod_info -> return (showModMsg obj_linkable mod_summary) where - obj_linkable = isObjectLinkable (hm_linkable mod_info) + obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info)) #endif /* GHCI */ diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 9fecb09..f9b996c 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -11,7 +11,7 @@ module HscTypes ( Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, - ModDetails(..), + ModDetails(..), emptyModDetails, ModGuts(..), ModImports(..), ForeignStubs(..), ModSummary(..), showModMsg, isBootSummary, @@ -214,9 +214,15 @@ emptyHomePackageTable = emptyModuleEnv emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo - = HomeModInfo { hm_iface :: ModIface, - hm_details :: ModDetails, - hm_linkable :: Linkable } + = HomeModInfo { hm_iface :: !ModIface, + hm_details :: !ModDetails, + hm_linkable :: !(Maybe Linkable) } + -- hm_linkable might be Nothing if: + -- a) this is an .hs-boot module + -- b) temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- after a complete compilation (GHC.load), all hm_linkable + -- fields in the HPT will be Just. \end{code} Simple lookups in the symbol table. @@ -358,6 +364,10 @@ data ModDetails md_rules :: ![IdCoreRule] -- Domain may include Ids from other modules } +emptyModDetails = ModDetails { md_types = emptyTypeEnv, + md_insts = [], + md_rules = [] } + -- A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a ModIface and @@ -940,7 +950,8 @@ data ModSummary ms_mod :: Module, -- Name of the module ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core ms_location :: ModLocation, -- Location - ms_hs_date :: ClockTime, -- Timestamp of summarised file + ms_hs_date :: ClockTime, -- Timestamp of source file + ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe ms_srcimps :: [Module], -- Source imports ms_imps :: [Module], -- Non-source imports ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source, diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 3f581e2..0df3d18 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -47,6 +47,7 @@ import Module ( Module, mkModule ) import UniqFM import UniqSet import Util +import Maybes ( expectJust ) import Panic import Outputable @@ -60,7 +61,7 @@ import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version import System.IO ( hPutStrLn, stderr ) -import Data.Maybe ( fromJust, isNothing ) +import Data.Maybe ( isNothing ) import System.Directory ( doesFileExist ) import Control.Monad ( when, foldM ) import Data.List ( nub, partition ) @@ -177,7 +178,7 @@ extendPackageConfigMap pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p getPackageDetails :: PackageState -> PackageId -> PackageConfig -getPackageDetails dflags ps = fromJust (lookupPackage (pkgIdMap dflags) ps) +getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkgIdMap dflags) ps) -- ---------------------------------------------------------------------------- -- Loading the package config files and building up the package state @@ -354,7 +355,7 @@ mkPackageState dflags pkg_db = do let extend_modmap modmap pkgname = do let - pkg = fromJust (lookupPackage pkg_db pkgname) + pkg = expectJust "mkPackageState" (lookupPackage pkg_db pkgname) exposed_mods = map mkModule (exposedModules pkg) hidden_mods = map mkModule (hiddenModules pkg) all_mods = exposed_mods ++ hidden_mods diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index d51a09d..2f20226 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -56,6 +56,7 @@ module Util ( -- IO-ish utilities createDirectoryHierarchy, doesDirNameExist, + modificationTimeIfExists, later, handleDyn, handle, @@ -89,10 +90,12 @@ import List ( zipWith4 ) #endif import Monad ( when ) -import IO ( catch ) +import IO ( catch, isDoesNotExistError ) import Directory ( doesDirectoryExist, createDirectory ) import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) import Ratio ( (%) ) +import Time ( ClockTime ) +import Directory ( getModificationTime ) infixr 9 `thenCmp` \end{code} @@ -840,6 +843,16 @@ handle h f = f `Exception.catch` \e -> case e of #endif -- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) +modificationTimeIfExists f = do + (do t <- getModificationTime f; return (Just t)) + `IO.catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- -- Filename manipulation type Suffix = String