X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=09f1db8f4b41c5e3e6391d988f4248e3e1755432;hb=c2f8c96bd08f57f6e6d74307a2a4708631337ebc;hp=3b5356428536ab0d37ab897b0bdadeba225e9886;hpb=96cf57e3ca14b3d9e6654a7780ea0b0ea4f5c0e8;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 3b53564..09f1db8 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,7 +4,7 @@ \section[CompManager]{The Compilation Manager} \begin{code} -module CompManager ( cmInit, cmLoadModule, +module CompManager ( cmInit, cmLoadModule, cmUnload, #ifdef GHCI cmGetExpr, cmRunExpr, #endif @@ -17,34 +17,34 @@ where import CmLink import CmTypes import HscTypes -import Module ( ModuleName, moduleName, - isHomeModule, moduleEnvElts, - moduleNameUserString ) -import CmStaticInfo ( PackageConfigInfo, GhciMode(..) ) +import Module ( Module, ModuleName, moduleName, isHomeModule, + mkModuleName, moduleNameUserString ) +import CmStaticInfo ( GhciMode(..) ) import DriverPipeline import GetImports import HscTypes ( HomeSymbolTable, HomeIfaceTable, PersistentCompilerState, ModDetails(..) ) -import Name ( lookupNameEnv ) -import Module -import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) import Finder import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, UniqFM, listToUFM ) import Unique ( Uniquable ) -import Digraph ( SCC(..), stronglyConnComp ) +import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) +import DriverFlags ( getDynFlags ) import DriverPhases -import DriverUtil ( BarfKind(..), splitFilename3 ) +import DriverUtil ( splitFilename3 ) +import ErrUtils ( showPass ) import Util +import DriverUtil import Outputable -import Panic ( panic ) +import Panic +import CmdLineOpts ( DynFlags(..) ) +import IOExts #ifdef GHCI -import CmdLineOpts ( DynFlags ) import Interpreter ( HValue ) import HscMain ( hscExpr ) -import RdrName +import Type ( Type ) import PrelGHC ( unsafeCoerce# ) #endif @@ -55,35 +55,37 @@ import Exception ( throwDyn ) import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) import IO +import Monad import List ( nub ) -import Maybe ( catMaybes, fromMaybe, isJust ) +import Maybe ( catMaybes, fromMaybe, isJust, fromJust ) \end{code} \begin{code} -cmInit :: PackageConfigInfo -> GhciMode -> IO CmState -cmInit raw_package_info gmode - = emptyCmState raw_package_info gmode +cmInit :: GhciMode -> IO CmState +cmInit gmode + = emptyCmState gmode #ifdef GHCI cmGetExpr :: CmState -> DynFlags - -> ModuleName + -> Bool -- True <=> wrap in 'print' to get an IO-typed result + -> Module -> String - -> IO (CmState, Maybe HValue) -cmGetExpr cmstate dflags modname expr - = do (new_pcs, maybe_unlinked_iexpr) <- - hscExpr dflags hst hit pcs (mkHomeModule modname) expr - case maybe_unlinked_iexpr of + -> IO (CmState, Maybe (HValue, PrintUnqualified, Type)) +cmGetExpr cmstate dflags wrap_io mod expr + = do (new_pcs, maybe_stuff) <- + hscExpr dflags wrap_io hst hit pcs mod expr + case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) - Just uiexpr -> do - hValue <- linkExpr pls uiexpr - return (cmstate{ pcs=new_pcs }, Just hValue) + Just (bcos, print_unqual, ty) -> do + hValue <- linkExpr pls bcos + return (cmstate{ pcs=new_pcs }, + Just (hValue, print_unqual, ty)) -- ToDo: check that the module we passed in is sane/exists? where - CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate - PersistentCMState{ hst=hst, hit=hit } = pcms + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate -- The HValue should represent a value of type IO () (Perhaps IO a?) cmRunExpr :: HValue -> IO () @@ -92,44 +94,33 @@ cmRunExpr hval -- putStrLn "done." #endif --- Persistent state just for CM, excluding link & compile subsystems -data PersistentCMState - = PersistentCMState { - hst :: HomeSymbolTable, -- home symbol table - hit :: HomeIfaceTable, -- home interface table - ui :: UnlinkedImage, -- the unlinked images - mg :: ModuleGraph, -- the module graph - pci :: PackageConfigInfo, -- NEVER CHANGES - gmode :: GhciMode -- NEVER CHANGES - } - -emptyPCMS :: PackageConfigInfo -> GhciMode -> PersistentCMState -emptyPCMS pci gmode - = PersistentCMState { hst = emptyHST, hit = emptyHIT, - ui = emptyUI, mg = emptyMG, - pci = pci, gmode = gmode } - emptyHIT :: HomeIfaceTable emptyHIT = emptyUFM emptyHST :: HomeSymbolTable emptyHST = emptyUFM - - -- Persistent state for the entire system data CmState = CmState { - pcms :: PersistentCMState, -- CM's persistent state + hst :: HomeSymbolTable, -- home symbol table + hit :: HomeIfaceTable, -- home interface table + ui :: UnlinkedImage, -- the unlinked images + mg :: ModuleGraph, -- the module graph + gmode :: GhciMode, -- NEVER CHANGES + pcs :: PersistentCompilerState, -- compile's persistent state pls :: PersistentLinkerState -- link's persistent state } -emptyCmState :: PackageConfigInfo -> GhciMode -> IO CmState -emptyCmState pci gmode - = do let pcms = emptyPCMS pci gmode - pcs <- initPersistentCompilerState +emptyCmState :: GhciMode -> IO CmState +emptyCmState gmode + = do pcs <- initPersistentCompilerState pls <- emptyPLS - return (CmState { pcms = pcms, + return (CmState { hst = emptyHST, + hit = emptyHIT, + ui = emptyUI, + mg = emptyMG, + gmode = gmode, pcs = pcs, pls = pls }) @@ -144,6 +135,21 @@ emptyMG = [] \end{code} +Unload the compilation manager's state: everything it knows about the +current collection of modules in the Home package. + +\begin{code} +cmUnload :: CmState -> IO CmState +cmUnload state + = do -- Throw away the old home dir cache + emptyHomeDirCache + -- Throw away the HIT and the HST + return state{ hst=new_hst, hit=new_hit, ui=emptyUI } + where + CmState{ hst=hst, hit=hit } = state + (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit) +\end{code} + The real business of the compilation manager: given a system state and a module name, try and bring the module up to date, probably changing the system state at the same time. @@ -153,37 +159,39 @@ cmLoadModule :: CmState -> FilePath -> IO (CmState, -- new state Bool, -- was successful - [ModuleName]) -- list of modules loaded + [Module]) -- list of modules loaded cmLoadModule cmstate1 rootname = do -- version 1's are the original, before downsweep - let pcms1 = pcms cmstate1 let pls1 = pls cmstate1 let pcs1 = pcs cmstate1 - let mg1 = mg pcms1 - let hst1 = hst pcms1 - let hit1 = hit pcms1 - let ui1 = ui pcms1 - - let pcii = pci pcms1 -- this never changes - let ghci_mode = gmode pcms1 -- ToDo: fix! + let hst1 = hst cmstate1 + let hit1 = hit cmstate1 + -- similarly, ui1 is the (complete) set of linkables from + -- the previous pass, if any. + let ui1 = ui cmstate1 + let mg1 = mg cmstate1 + + let ghci_mode = gmode cmstate1 -- this never changes -- Do the downsweep to reestablish the module graph - -- then generate version 2's by removing from HIT,HST,UI any - -- modules in the old MG which are not in the new one. + -- then generate version 2's by retaining in HIT,HST,UI a + -- stable set S of modules, as defined below. - -- Throw away the old home dir cache - emptyHomeDirCache + dflags <- getDynFlags + let verb = verbosity dflags - hPutStr stderr "cmLoadModule: downsweep begins\n" - mg2unsorted <- downsweep [rootname] + showPass dflags "Chasing dependencies" + when (verb >= 1 && ghci_mode == Batch) $ + hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname) - let modnames1 = map name_of_summary mg1 - let modnames2 = map name_of_summary mg2unsorted - let mods_to_zap = filter (`notElem` modnames2) modnames1 + (mg2unsorted, a_root_is_Main) <- downsweep [rootname] mg1 + let mg2unsorted_names = map name_of_summary mg2unsorted - let (hst2, hit2, ui2) - = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1) + -- reachable_from follows source as well as normal imports + let reachable_from :: ModuleName -> [ModuleName] + 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 @@ -191,12 +199,52 @@ cmLoadModule cmstate1 rootname -- upsweep, and for removing from hst/hit all the modules -- not in strict downwards closure, during calls to compile. let mg2_with_srcimps = topological_sort True mg2unsorted - - let reachable_from :: ModuleName -> [ModuleName] - reachable_from = downwards_closure_of_module mg2unsorted - hPutStrLn stderr "after tsort:\n" - hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + -- Sort out which linkables we wish to keep in the unlinked image. + -- See getValidLinkables below for details. + valid_linkables <- getValidLinkables ui1 mg2unsorted_names + mg2_with_srcimps + + -- 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 linkable exists for each module in ms + + stable_mods + <- 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 + -- done before the upsweep is abandoned. + let upsweep_these + = filter (\scc -> any (`notElem` stable_mods) + (map name_of_summary (flattenSCC scc))) + mg2 + + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) -- Because we don't take into account source imports when doing -- the topological sort, there shouldn't be any cycles in mg2. @@ -206,18 +254,27 @@ cmLoadModule cmstate1 rootname -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. - let threaded2 = CmThreaded pcs1 hst2 hit2 + let threaded2 = CmThreaded pcs1 hst1 hit1 - (upsweep_complete_success, threaded3, modsDone, newLis) - <- upsweep_mods ghci_mode ui2 reachable_from threaded2 mg2 + (upsweep_complete_success, threaded3, modsUpswept, newLis) + <- upsweep_mods ghci_mode dflags valid_linkables reachable_from + threaded2 upsweep_these - let ui3 = add_to_ui ui2 newLis + let ui3 = add_to_ui valid_linkables newLis let (CmThreaded pcs3 hst3 hit3) = threaded3 - -- At this point, modsDone and newLis should have the same + -- 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). + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domains of hst3 and hit3. + -- (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 + -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. @@ -225,26 +282,28 @@ cmLoadModule cmstate1 rootname then -- Easy; just relink it all. - do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL" + do when (verb >= 2) $ + hPutStrLn stderr "Upsweep completely successful." linkresult - <- link ghci_mode (any exports_main (moduleEnvElts hst3)) - newLis pls1 + <- link ghci_mode dflags a_root_is_Main ui3 pls2 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (1)" LinkOK pls3 - -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3, - ui=ui3, mg=modsDone, - pci=pcii, gmode=ghci_mode } - let cmstate3 - = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 } - return (cmstate3, True, map name_of_summary modsDone) + -> do let cmstate3 + = CmState { hst=hst3, hit=hit3, + ui=ui3, mg=modsDone, + gmode=ghci_mode, + pcs=pcs3, pls=pls3 } + return (cmstate3, True, + map ms_mod modsDone) else -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL" + do when (verb >= 2) $ + hPutStrLn stderr "Upsweep partially successful." let modsDone_names = map name_of_summary modsDone @@ -262,19 +321,197 @@ cmLoadModule cmstate1 rootname = map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4) mods_to_keep_names - linkresult <- link ghci_mode False linkables_to_link pls1 + linkresult <- link ghci_mode dflags False linkables_to_link pls2 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (2)" - LinkOK pls4 - -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4, - ui=ui4, mg=mods_to_keep, - pci=pcii, gmode=ghci_mode } - let cmstate4 - = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 } - return (cmstate4, False, mods_to_keep_names) + LinkOK pls3 + -> do let cmstate4 + = CmState { hst=hst4, hit=hit4, + ui=ui4, mg=mods_to_keep, + gmode=ghci_mode, pcs=pcs3, pls=pls3 } + return (cmstate4, False, + map ms_mod mods_to_keep) + + +----------------------------------------------------------------------------- +-- getValidLinkables + +-- For each module (or SCC of modules), we take: +-- +-- - the old in-core linkable, if available +-- - an on-disk linkable, if available +-- +-- and we take the youngest of these, provided it is younger than the +-- source file. We ignore the on-disk linkables unless all of the +-- dependents of this SCC also have on-disk linkables. +-- +-- 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. + +getValidLinkables + :: [Linkable] -- old linkables + -> [ModuleName] -- all home modules + -> [SCC ModSummary] -- all modules in the program, dependency order + -> IO [Linkable] -- still-valid linkables + +getValidLinkables old_linkables all_home_mods module_graph + = foldM (getValidLinkablesSCC old_linkables all_home_mods) [] module_graph + +getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0 + = let + scc = flattenSCC scc0 + scc_names = map name_of_summary scc + home_module m = m `elem` all_home_mods && m `notElem` scc_names + scc_allhomeimps = nub (filter home_module (concatMap ms_allimps scc)) + + has_object m = case findModuleLinkable_maybe new_linkables m of + Nothing -> False + Just l -> isObjectLinkable l + + objects_allowed = all has_object scc_allhomeimps + in do + + these_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. + adjusted_linkables + <- if objects_allowed && not (all isObjectLinkable these_linkables) + then foldM (getValidLinkable old_linkables False) [] scc + else return these_linkables + + return (adjusted_linkables ++ new_linkables) + + +getValidLinkable :: [Linkable] -> Bool -> [Linkable] -> ModSummary + -> IO [Linkable] +getValidLinkable old_linkables objects_allowed new_linkables summary + = do + let mod_name = name_of_summary summary + + maybe_disk_linkable + <- if (not objects_allowed) + then return Nothing + else case ml_obj_file (ms_location summary) of + Just obj_fn -> maybe_getFileLinkable mod_name obj_fn + Nothing -> return Nothing + + -- find an old in-core linkable if we have one. (forget about + -- on-disk linkables for now, we'll check again whether there's + -- one here below, just in case a new one has popped up recently). + let old_linkable = findModuleLinkable_maybe old_linkables mod_name + maybe_old_linkable = + case old_linkable of + Just (LM _ _ ls) | all isInterpretable ls -> old_linkable + _ -> Nothing + + -- The most recent of the old UI linkable or whatever we could + -- find on disk is returned as the linkable if compile + -- doesn't think we need to recompile. + let linkable_list + = case (maybe_old_linkable, maybe_disk_linkable) of + (Nothing, Nothing) -> [] + (Nothing, Just di) -> [di] + (Just ui, Nothing) -> [ui] + (Just ui, Just di) + | linkableTime ui >= linkableTime di -> [ui] + | otherwise -> [di] + + -- only linkables newer than the source code are valid + let maybe_src_date = ms_hs_date summary + + valid_linkable_list + = case maybe_src_date of + Nothing -> panic "valid_linkable_list" + Just src_date + -> filter (\li -> linkableTime li > src_date) linkable_list + + return (valid_linkable_list ++ new_linkables) + + +maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) +maybe_getFileLinkable mod_name obj_fn + = do 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_name [DotO obj_fn, DotO stub_fn])) + else return (Just (LM obj_time mod_name [DotO obj_fn])) +----------------------------------------------------------------------------- +-- Do a pre-upsweep without use of "compile", to establish a +-- (downward-closed) set of stable modules for which we won't call compile. + +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 old_lis all_home_mods stable [] + = return stable +preUpsweep valid_lis old_lis all_home_mods stable (scc0:sccs) + = do let scc = flattenSCC scc0 + scc_allhomeimps :: [ModuleName] + 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_names + = map name_of_summary scc + in_stable_or_scc m + = m `elem` scc_names || m `elem` stable + + -- 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 +-- stable (in the sense of preUpsweep), determine if new_summary is itself +-- stable, and, if so, in batch mode, return its linkable. +findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary] +findInSummaries old_summaries mod_name + = [s | s <- old_summaries, name_of_summary 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 :: [ModuleName] -> [SCC ModSummary] -> [ModuleName] @@ -296,27 +533,16 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest --- Does this ModDetails export Main.main? -exports_main :: ModDetails -> Bool -exports_main md - = isJust (lookupNameEnv (md_types md) mainName) - - -- Add the given (LM-form) Linkables to the UI, overwriting previous -- versions if they exist. add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage add_to_ui ui lis - = foldr add1 ui lis + = filter (not_in lis) ui ++ lis where - add1 :: Linkable -> UnlinkedImage -> UnlinkedImage - add1 li ui - = li : filter (\li2 -> not (for_same_module li li2)) ui - - for_same_module :: Linkable -> Linkable -> Bool - for_same_module li1 li2 - = not (is_package_linkable li1) - && not (is_package_linkable li2) - && modname_of_linkable li1 == modname_of_linkable li2 + not_in :: [Linkable] -> Linkable -> Bool + not_in lis li + = all (\l -> linkableModName l /= mod) lis + where mod = linkableModName li data CmThreaded -- stuff threaded through individual module compilations @@ -326,7 +552,8 @@ data CmThreaded -- stuff threaded through individual module compilations -- 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 :: GhciMode - -> UnlinkedImage -- old linkables + -> DynFlags + -> UnlinkedImage -- valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures -> CmThreaded -- PCS & HST & HIT -> [SCC ModSummary] -- mods to do (the worklist) @@ -336,26 +563,30 @@ upsweep_mods :: GhciMode [ModSummary], -- mods which succeeded [Linkable]) -- new linkables -upsweep_mods ghci_mode oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded [] = return (True, threaded, [], []) -upsweep_mods ghci_mode oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded ((CyclicSCC ms):_) - = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++ + = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.name_of_summary) ms)) return (False, threaded, [], []) -upsweep_mods ghci_mode oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded ((AcyclicSCC mod):mods) - = do (threaded1, maybe_linkable) - <- upsweep_mod ghci_mode oldUI threaded mod - (reachable_from (name_of_summary mod)) + = do --case threaded of + -- CmThreaded pcsz hstz hitz + -- -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz))) + + (threaded1, maybe_linkable) + <- upsweep_mod ghci_mode dflags oldUI threaded mod + (reachable_from (name_of_summary mod)) case maybe_linkable of Just linkable -> -- No errors; do the rest do (restOK, threaded2, modOKs, linkables) - <- upsweep_mods ghci_mode oldUI reachable_from + <- upsweep_mods ghci_mode dflags oldUI reachable_from threaded1 mods return (restOK, threaded2, mod:modOKs, linkable:linkables) Nothing -- we got a compilation error; give up now @@ -364,73 +595,39 @@ upsweep_mods ghci_mode oldUI reachable_from threaded -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) -maybe_getFileLinkable mod_name obj_fn - = do 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_name [DotO obj_fn, DotO stub_fn])) - else return (Just (LM obj_time mod_name [DotO obj_fn])) - - upsweep_mod :: GhciMode + -> DynFlags -> UnlinkedImage -> CmThreaded -> ModSummary -> [ModuleName] -> IO (CmThreaded, Maybe Linkable) -upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here - = do let mod_name = name_of_summary summary1 +upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here + = do + let mod_name = name_of_summary summary1 + let verb = verbosity dflags + + when (verb == 1) $ + if (ghci_mode == Batch) + then hPutStr stderr (progName ++ ": module " + ++ moduleNameUserString mod_name + ++ ": ") + else hPutStr stderr ("Compiling " + ++ moduleNameUserString mod_name + ++ " ... ") + let (CmThreaded pcs1 hst1 hit1) = threaded1 - let old_iface = lookupUFM hit1 (name_of_summary summary1) - - -- We *have* to compile it if we're in batch mode and we can't see - -- a previous linkable for it on disk. - compilation_mandatory - <- if ghci_mode /= Batch then return False - else case ml_obj_file (ms_location summary1) of - Nothing -> do --putStrLn "cmcm: object?!" - return True - Just obj_fn -> do --putStrLn ("cmcm: old obj " ++ obj_fn) - b <- doesFileExist obj_fn - return (not b) - - let maybe_oldUI_linkable = findModuleLinkable_maybe oldUI mod_name - maybe_oldDisk_linkable - <- case ml_obj_file (ms_location summary1) of - Nothing -> return Nothing - Just obj_fn -> maybe_getFileLinkable mod_name obj_fn + let old_iface = lookupUFM hit1 mod_name - -- The most recent of the old UI linkable or whatever we could - -- find on disk. Is returned as the linkable if compile - -- doesn't think we need to recompile. - let maybe_old_linkable - = case (maybe_oldUI_linkable, maybe_oldDisk_linkable) of - (Nothing, Nothing) -> Nothing - (Nothing, Just di) -> Just di - (Just ui, Nothing) -> Just ui - (Just ui, Just di) - | linkableTime ui >= linkableTime di -> Just ui - | otherwise -> Just di - - let compilation_mandatory - = case maybe_old_linkable of - Nothing -> True - Just li -> case ms_hs_date summary1 of - Nothing -> panic "compilation_mandatory:no src date" - Just src_date -> src_date >= linkableTime li - source_unchanged - = not compilation_mandatory + let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name + + source_unchanged = isJust maybe_old_linkable (hst1_strictDC, hit1_strictDC) - = retainInTopLevelEnvs reachable_from_here (hst1,hit1) + = retainInTopLevelEnvs + (filter (/= (name_of_summary summary1)) reachable_from_here) + (hst1,hit1) old_linkable = unJust "upsweep_mod:old_linkable" maybe_old_linkable @@ -444,25 +641,38 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here -- linkable, meaning that compilation wasn't needed, and the -- new details were manufactured from the old iface. CompOK pcs2 new_details new_iface Nothing - -> let hst2 = addToUFM hst1 mod_name new_details - hit2 = addToUFM hit1 mod_name new_iface - threaded2 = CmThreaded pcs2 hst2 hit2 - in return (threaded2, Just old_linkable) + -> do let hst2 = addToUFM hst1 mod_name new_details + hit2 = addToUFM hit1 mod_name new_iface + threaded2 = CmThreaded pcs2 hst2 hit2 + + if ghci_mode == Interactive && verb >= 1 then + -- if we're using an object file, tell the user + case old_linkable of + (LM _ _ objs@(DotO _:_)) + -> do hPutStrLn stderr (showSDoc (space <> + parens (hsep (text "using": + punctuate comma + [ text o | DotO o <- objs ])))) + _ -> return () + else + return () + + return (threaded2, Just old_linkable) -- Compilation really did happen, and succeeded. A new -- details, iface and linkable are returned. CompOK pcs2 new_details new_iface (Just new_linkable) - -> let hst2 = addToUFM hst1 mod_name new_details - hit2 = addToUFM hit1 mod_name new_iface - threaded2 = CmThreaded pcs2 hst2 hit2 - in return (threaded2, Just new_linkable) + -> do let hst2 = addToUFM hst1 mod_name new_details + hit2 = addToUFM hit1 mod_name new_iface + threaded2 = CmThreaded pcs2 hst2 hit2 + + return (threaded2, Just new_linkable) -- Compilation failed. compile may still have updated -- the PCS, tho. CompErrs pcs2 - -> let threaded2 = CmThreaded pcs2 hst1 hit1 - in return (threaded2, Nothing) - + -> do let threaded2 = CmThreaded pcs2 hst1 hit1 + return (threaded2, Nothing) -- Remove unwanted modules from the top level envs (HST, HIT, UI). removeFromTopLevelEnvs :: [ModuleName] @@ -492,14 +702,13 @@ retainInTopLevelEnvs keep_these (hst, hit) downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName] downwards_closure_of_module summaries root = let toEdge :: ModSummary -> (ModuleName,[ModuleName]) - toEdge summ - = (name_of_summary summ, ms_srcimps summ ++ ms_imps summ) + toEdge summ = (name_of_summary summ, ms_allimps summ) res = simple_transitive_closure (map toEdge summaries) [root] in - trace (showSDoc (text "DC of mod" <+> ppr root - <+> text "=" <+> ppr res)) ( + --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] @@ -541,54 +750,70 @@ topological_sort include_source_imports summaries -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import --- links. -downsweep :: [FilePath] -> IO [ModSummary] -downsweep rootNm +-- links. Also returns a Bool to indicate whether any of the roots +-- are module Main. +downsweep :: [FilePath] -> [ModSummary] -> IO ([ModSummary], Bool) +downsweep rootNm old_summaries = do rootSummaries <- mapM getRootSummary rootNm - loop (filter (isHomeModule.ms_mod) rootSummaries) + let a_root_is_Main + = any ((=="Main").moduleNameUserString.name_of_summary) + rootSummaries + all_summaries + <- loop (concat (map ms_imps rootSummaries)) + (filter (isHomeModule.ms_mod) rootSummaries) + return (all_summaries, a_root_is_Main) where getRootSummary :: FilePath -> IO ModSummary getRootSummary file | haskellish_file file - = do exists <- doesFileExist file - if exists then summariseFile file - else getSummary (mkModuleName file) - -- ToDo: should check import paths - | otherwise - = getSummary (mkModuleName file) + = do exists <- doesFileExist file + if exists then summariseFile file else do + throwDyn (OtherError ("can't find file `" ++ file ++ "'")) + | otherwise + = do exists <- doesFileExist hs_file + if exists then summariseFile hs_file else do + exists <- doesFileExist lhs_file + if exists then summariseFile lhs_file else do + getSummary (mkModuleName file) + where + hs_file = file ++ ".hs" + lhs_file = file ++ ".lhs" getSummary :: ModuleName -> IO ModSummary getSummary nm - | trace ("getSummary: "++ showSDoc (ppr nm)) True = do found <- findModule nm case found of - -- Be sure not to use the mod and location passed in to - -- summarise for any other purpose -- summarise may change - -- the module names in them if name of module /= name of file, - -- and put the changed versions in the returned summary. - -- These will then conflict with the passed-in versions. - Just (mod, location) -> summarise mod location + Just (mod, location) -> do + let old_summary = findModInSummaries old_summaries mod + new_summary <- summarise mod location old_summary + case new_summary of + Nothing -> return (fromJust old_summary) + Just s -> return s + Nothing -> throwDyn (OtherError - ("no signs of life for module `" + ("can't find module `" ++ showSDoc (ppr nm) ++ "'")) - -- loop invariant: homeSummaries doesn't contain package modules - loop :: [ModSummary] -> IO [ModSummary] - loop homeSummaries - = do let allImps :: [ModuleName] - allImps = (nub . concatMap ms_imps) homeSummaries - let allHome -- all modules currently in homeSummaries - = map (moduleName.ms_mod) homeSummaries - let neededImps - = filter (`notElem` allHome) allImps - neededSummaries - <- mapM getSummary neededImps - let newHomeSummaries - = filter (isHomeModule.ms_mod) neededSummaries - if null newHomeSummaries - then return homeSummaries - else loop (newHomeSummaries ++ homeSummaries) + -- loop invariant: home_summaries doesn't contain package modules + loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary] + loop [] home_summaries = return home_summaries + loop imps home_summaries + = do -- all modules currently in homeSummaries + let all_home = map (moduleName.ms_mod) home_summaries + + -- imports for modules we don't already have + let needed_imps = nub (filter (`notElem` all_home) imps) + -- summarise them + needed_summaries <- mapM getSummary needed_imps + + -- get just the "home" modules + let new_home_summaries + = filter (isHomeModule.ms_mod) needed_summaries + + -- loop, checking the new imports + let new_imps = concat (map ms_imps new_home_summaries) + loop new_imps (new_home_summaries ++ home_summaries) ----------------------------------------------------------------------------- -- Summarising modules @@ -624,11 +849,23 @@ summariseFile file srcimps imps maybe_src_timestamp) --- Summarise a module, and pick up source and interface timestamps. -summarise :: Module -> ModuleLocation -> IO ModSummary -summarise mod location +-- Summarise a module, and pick up source and timestamp. +summarise :: Module -> ModuleLocation -> Maybe ModSummary + -> IO (Maybe ModSummary) +summarise mod location old_summary | isHomeModule mod = do let hs_fn = unJust "summarise" (ml_hs_file location) + + maybe_src_timestamp + <- case ml_hs_file location of + Nothing -> return Nothing + Just src_fn -> maybe_getModificationTime src_fn + + -- return the cached summary if the source didn't change + case old_summary of { + Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing; + _ -> do + hspp_fn <- preprocess hs_fn modsrc <- readFile hspp_fn let (srcimps,imps,mod_name) = getImports modsrc @@ -638,19 +875,19 @@ summarise mod location Nothing -> return Nothing Just src_fn -> maybe_getModificationTime src_fn - if mod_name == moduleName mod - then return () - else throwDyn (OtherError - (showSDoc (text "file name does not match module name: " - <+> ppr (moduleName mod) <+> text "vs" - <+> ppr mod_name))) + when (mod_name /= moduleName mod) $ + throwDyn (OtherError + (showSDoc (text "file name does not match module name: " + <+> ppr (moduleName mod) <+> text "vs" + <+> ppr mod_name))) - return (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp) + return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} + srcimps imps + maybe_src_timestamp)) + } | otherwise - = return (ModSummary mod location [] [] Nothing) + = return (Just (ModSummary mod location [] [] Nothing)) maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) maybe_getModificationTime fn