From 0ed9d26049e04d4249f9b7852647c2cac375508c Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 6 Feb 2001 12:03:10 +0000 Subject: [PATCH] [project @ 2001-02-06 12:03:10 by simonmar] Try to get the stable modules story right. Things now work much better: objects aren't unloaded and reloaded unnecessarily, and compiling modules from with GHCi works: > :! ghc -c A.hs > :r Compiling A ... compilation IS NOT required (using ./A.o) Compiling B ... compilation IS NOT required Compiling C ... compilation IS NOT required Compiling Main ... compilation IS NOT required Compiled module must not depend on interpreted modules, but we currently don't enforce this restriction properly. --- ghc/compiler/compMan/CmLink.lhs | 123 +++++++++++++++++++++------------- ghc/compiler/compMan/CmTypes.lhs | 16 ++--- ghc/compiler/compMan/CompManager.lhs | 62 +++++++++++------ 3 files changed, 121 insertions(+), 80 deletions(-) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 08c2775..9ea08da 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -7,7 +7,6 @@ module CmLink ( Linkable(..), Unlinked(..), filterModuleLinkables, findModuleLinkable_maybe, - modname_of_linkable, is_package_linkable, LinkResult(..), link, unload, @@ -32,6 +31,7 @@ import CmdLineOpts ( DynFlags(..) ) import Panic ( panic, GhcException(..) ) import Exception +import List import Monad import IO @@ -55,8 +55,9 @@ data PersistentLinkerState itbl_env :: ItblEnv, -- list of objects we've loaded (we'll need to unload them again - -- before re-loading the same module). - objects_loaded :: [FilePath] + -- before re-loading the same module), together with the ClockTime + -- of the linkable they were loaded from. + objects_loaded :: [Linkable] -- notionally here, but really lives in the C part of the linker: -- object_symtab :: FiniteMap String Addr @@ -86,13 +87,58 @@ emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, #else emptyPLS = return (PersistentLinkerState {}) #endif -\end{code} -\begin{code} +----------------------------------------------------------------------------- +-- Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers "stable", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one - the +-- user may have recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- + +unload :: GhciMode + -> DynFlags + -> [Linkable] -- stable linkables + -> PersistentLinkerState + -> IO PersistentLinkerState + +unload Batch dflags linkables pls = return pls +unload Interactive dflags linkables pls + = do new_loaded <- filterM maybeUnload (objects_loaded pls) + let mods_retained = map linkableModName new_loaded + itbl_env' = filterNameMap mods_retained (itbl_env pls) + closure_env' = filterNameMap mods_retained (closure_env pls) + + let verb = verbosity dflags + when (verb >= 3) $ do + hPutStrLn stderr (showSDoc + (text "CmLink.unload: retaining" <+> ppr mods_retained)) + + return pls{ objects_loaded = new_loaded, + itbl_env = itbl_env', + closure_env = closure_env' } + where + maybeUnload :: Linkable -> IO Bool + maybeUnload (LM time mod objs) = do + case findModuleLinkable_maybe linkables mod of + Nothing -> do unloadObjs; return False + Just l | linkableTime l /= time -> do unloadObjs; return False + | otherwise -> return True + where + unloadObjs = mapM unloadObj [ f | DotO f <- objs ] + +----------------------------------------------------------------------------- +-- Linking + link :: GhciMode -- interactive or batch -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode? - -> [Linkable] -- only contains LMs, not LPs + -> [Linkable] -> PersistentLinkerState -> IO LinkResult @@ -141,32 +187,21 @@ link' Batch dflags batch_attempt_linking linkables pls1 return (LinkOK pls1) where verb = verbosity dflags - getOfiles (LP _) = panic "CmLink.link(getOfiles): found package linkable" getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) -link' Interactive dflags batch_attempt_linking linkables pls1 +link' Interactive dflags batch_attempt_linking linkables pls = do showPass dflags "Linking" - pls2 <- unload pls1 - linkObjs linkables [] pls2 - -- reverse the linkables, to get the leaves of the tree first. + let (objs, bcos) = partition (isObject.head.linkableUnlinked) linkables + linkObjs (objs ++ bcos) pls + -- get the objects first ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC = ppr . flattenSCC - -modname_of_linkable (LM _ nm _) = nm -modname_of_linkable (LP _) = panic "modname_of_linkable: package" - -is_package_linkable (LP _) = True -is_package_linkable (LM _ _ _) = False - -filterModuleLinkables :: (ModuleName -> Bool) - -> [Linkable] - -> [Linkable] +filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] filterModuleLinkables p [] = [] filterModuleLinkables p (li:lis) = case li of - LP _ -> retain LM _ modnm _ -> if p modnm then retain else dump where dump = filterModuleLinkables p lis @@ -180,56 +215,48 @@ linkObjs = panic "CmLink.linkObjs: no interpreter" unload = panic "CmLink.unload: no interpreter" lookupClosure = panic "CmLink.lookupClosure: no interpreter" #else -linkObjs [] mods pls = linkFinish pls [] [] -linkObjs (l@(LM _ m uls) : ls) mods pls +linkObjs [] pls = linkFinish pls [] +linkObjs (l@(LM _ m uls) : ls) pls | all isObject uls = do + if isLoaded l pls then linkObjs ls pls else do let objs = [ file | DotO file <- uls ] mapM_ loadObj objs - linkObjs ls (m:mods) pls{objects_loaded = objs++objects_loaded pls} - | all isInterpretable uls = linkInterpretedCode (l:ls) mods [] pls + linkObjs ls pls{objects_loaded = l : objects_loaded pls} + | all isInterpretable uls = linkInterpretedCode (l:ls) [] pls | otherwise = invalidLinkable -linkObjs _ _ _ = - panic "CmLink.linkObjs: found package linkable" +isLoaded :: Linkable -> PersistentLinkerState -> Bool +isLoaded l pls = + case findModuleLinkable_maybe (objects_loaded pls) (linkableModName l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m -linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees -linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls +linkInterpretedCode [] ul_trees pls = linkFinish pls ul_trees +linkInterpretedCode (LM _ m uls : ls) ul_trees pls | all isInterpretable uls = - linkInterpretedCode ls (m:mods) (uls++ul_trees) pls + linkInterpretedCode ls (uls++ul_trees) pls | any isObject uls = throwDyn (OtherError "can't link object code that depends on interpreted code") | otherwise = invalidLinkable -linkInterpretedCode _ _ _ pls = - panic "CmLink.linkInterpretedCode: found package linkable" invalidLinkable = panic "CmLink: linkable doesn't contain entirely objects or interpreted code" --- link all the interpreted code in one go. We first remove from the --- various environments any previous versions of these modules. -linkFinish pls mods ul_bcos = do +-- link all the interpreted code in one go. +linkFinish pls ul_bcos = do resolveObjs - let itbl_env' = filterNameMap mods (itbl_env pls) - closure_env' = filterNameMap mods (closure_env pls) - stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] + + let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] (ibinds, new_itbl_env, new_closure_env) <- - linkIModules itbl_env' closure_env' stuff + linkIModules (itbl_env pls) (closure_env pls) stuff let new_pls = pls { closure_env = new_closure_env, itbl_env = new_itbl_env } return (LinkOK new_pls) --- purge the current "linked image" -unload :: PersistentLinkerState -> IO PersistentLinkerState -unload pls = do - mapM unloadObj (objects_loaded pls) - return pls{ closure_env = emptyFM, - itbl_env = emptyFM, - objects_loaded = [] } - linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos = linkIExpr ie ce bcos diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs index f9e251b..ef2a785 100644 --- a/ghc/compiler/compMan/CmTypes.lhs +++ b/ghc/compiler/compMan/CmTypes.lhs @@ -6,7 +6,7 @@ \begin{code} module CmTypes ( Unlinked(..), isObject, nameOfObject, isInterpretable, - Linkable(..), linkableTime, + Linkable(..), ModSummary(..), ms_allimps, name_of_summary, pprSummaryTime ) where @@ -44,20 +44,16 @@ nameOfObject (DotDLL fn) = fn isInterpretable (BCOs _ _) = True isInterpretable _ = False -data Linkable - = LM ClockTime ModuleName [Unlinked] - | LP PackageName +data Linkable = LM { + linkableTime :: ClockTime, + linkableModName :: ModuleName, + linkableUnlinked :: [Unlinked] + } instance Outputable Linkable where ppr (LM when_made mod_nm unlinkeds) = text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod_nm <+> ppr unlinkeds - ppr (LP package_nm) - = text "LinkableP" <+> ptext package_nm - -linkableTime (LM when_made mod_nm unlinkeds) = when_made -linkableTime (LP package_nm) = panic "linkableTime" - -- The ModuleLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 498ee07..9312df4 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -224,15 +224,24 @@ cmLoadModule cmstate1 rootname -- 2. A valid linkable exists for each module in ms stable_mods - <- preUpsweep valid_linkables mg2unsorted_names [] mg2_with_srcimps + <- preUpsweep valid_linkables ui1 mg2unsorted_names + [] mg2_with_srcimps let stable_summaries = concatMap (findInSummaries mg2unsorted) stable_mods + stable_linkables + = filter (\m -> linkableModName m `elem` stable_mods) + valid_linkables + when (verb >= 2) $ putStrLn (showSDoc (text "STABLE MODULES:" <+> sep (map (text.moduleNameUserString) stable_mods))) + -- unload any modules which aren't going to be re-linked this + -- time around. + pls2 <- unload ghci_mode dflags stable_linkables pls1 + -- 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 @@ -284,7 +293,7 @@ cmLoadModule cmstate1 rootname do when (verb >= 2) $ hPutStrLn stderr "Upsweep completely successful." linkresult - <- link ghci_mode dflags a_root_is_Main ui3 pls1 + <- link ghci_mode dflags a_root_is_Main ui3 pls2 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (1)" @@ -403,20 +412,18 @@ maybe_getFileLinkable mod_name obj_fn ----------------------------------------------------------------------------- -- Do a pre-upsweep without use of "compile", to establish a --- (downward-closed) set of stable modules which can be retained --- in the top-level environments. Also return linkables for those --- modules determined to be stable, since (in Batch mode, at least) --- there's no other way for them to get into UI. +-- (downward-closed) set of stable modules for which we won't call compile. -preUpsweep :: [Linkable] -- valid linkables +preUpsweep :: [Linkable] -- new valid linkables + -> [Linkable] -- old linkables -> [ModuleName] -- names of all mods encountered in downsweep -> [ModuleName] -- accumulating stable modules -> [SCC ModSummary] -- scc-ified mod graph, including src imps -> IO [ModuleName] -- stable modules -preUpsweep valid_lis all_home_mods stable [] +preUpsweep valid_lis old_lis all_home_mods stable [] = return stable -preUpsweep valid_lis all_home_mods stable (scc0:sccs) +preUpsweep valid_lis old_lis all_home_mods stable (scc0:sccs) = do let scc = flattenSCC scc0 scc_allhomeimps :: [ModuleName] scc_allhomeimps @@ -429,18 +436,29 @@ preUpsweep valid_lis all_home_mods stable (scc0:sccs) = --trace (showSDoc (text "ISOS" <+> ppr m <+> ppr scc_names <+> ppr stable)) ( m `elem` scc_names || m `elem` stable --) - all_scc_stable - <- if not all_imports_in_scc_or_stable - then do --putStrLn ("PART1 fail " ++ showSDoc (ppr scc_allhomeimps <+> ppr (filter (not.in_stable_or_scc) scc_allhomeimps))) - return False - else do --when (not (and bools)) (putStrLn ("PART2 fail: " ++ showSDoc (ppr scc_names))) - return (all is_stable scc) - if not all_scc_stable - then preUpsweep valid_lis all_home_mods stable sccs - else preUpsweep valid_lis all_home_mods (scc_names++stable) sccs - where is_stable new_summary - = isJust (findModuleLinkable_maybe valid_lis (name_of_summary new_summary)) + -- now we check for valid linkables: each module in the SCC must + -- have a valid linkable (see getValidLinkables above), and the + -- newest linkable must be the same as the previous linkable for + -- this module (if one exists). + has_valid_linkable new_summary + = case findModuleLinkable_maybe valid_lis modname of + Nothing -> False + Just l -> case findModuleLinkable_maybe old_lis modname of + Nothing -> True + Just m -> linkableTime l == linkableTime m + where modname = name_of_summary new_summary + + scc_is_stable = all_imports_in_scc_or_stable + && all has_valid_linkable scc + + if scc_is_stable + then preUpsweep valid_lis old_lis all_home_mods + (scc_names++stable) sccs + else preUpsweep valid_lis old_lis all_home_mods + stable sccs + + where -- Helper for preUpsweep. Assuming that new_summary's imports are all @@ -480,8 +498,8 @@ add_to_ui ui lis where not_in :: [Linkable] -> Linkable -> Bool not_in lis li - = all (\l -> modname_of_linkable l /= mod) lis - where mod = modname_of_linkable li + = all (\l -> linkableModName l /= mod) lis + where mod = linkableModName li data CmThreaded -- stuff threaded through individual module compilations -- 1.7.10.4