From: sewardj Date: Thu, 16 Nov 2000 16:23:04 +0000 (+0000) Subject: [project @ 2000-11-16 16:23:03 by sewardj] X-Git-Tag: Approximately_9120_patches~3323 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2829e3a6aa04df7da74c04e7784e5412a0d960b7;p=ghc-hetmet.git [project @ 2000-11-16 16:23:03 by sewardj] * Move along the source-changed checkery. * Make the driver put object files in the right place when using CM. * Don't do hscNoRecomp in one-shot mode. --- diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 0e46c88..9adf362 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -149,6 +149,7 @@ filterModuleLinkables p (li:lis) #ifndef GHCI linkObjs = panic "CmLink.linkObjs: no interpreter" +unload = panic "CmLink.unload: no interpreter" #else linkObjs [] pls = linkFinish pls [] [] linkObjs (l@(LM _ uls) : ls) pls diff --git a/ghc/compiler/compMan/CmStaticInfo.lhs b/ghc/compiler/compMan/CmStaticInfo.lhs index 5420bfc..a76ffc2 100644 --- a/ghc/compiler/compMan/CmStaticInfo.lhs +++ b/ghc/compiler/compMan/CmStaticInfo.lhs @@ -12,7 +12,8 @@ where \end{code} \begin{code} -data GhciMode = Batch | Interactive +data GhciMode = Batch | Interactive | OneShot + deriving Eq type PackageConfigInfo = [Package] diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs index a57ef9e..7332361 100644 --- a/ghc/compiler/compMan/CmTypes.lhs +++ b/ghc/compiler/compMan/CmTypes.lhs @@ -7,7 +7,7 @@ module CmTypes ( Unlinked(..), isObject, nameOfObject, isInterpretable, Linkable(..), - ModSummary(..), name_of_summary + ModSummary(..), name_of_summary, pprSummaryTimes ) where import Interpreter @@ -16,6 +16,9 @@ import Module import CmStaticInfo import Outputable +import Time ( ClockTime ) + + data Unlinked = DotO FilePath | DotA FilePath @@ -58,23 +61,30 @@ instance Outputable Linkable where data ModSummary = ModSummary { ms_mod :: Module, -- name, package - ms_location :: ModuleLocation, -- location + ms_location :: ModuleLocation, -- location ms_srcimps :: [ModuleName], -- source imports - ms_imps :: [ModuleName] -- non-source imports - --ms_date :: Maybe ClockTime -- timestamp of summarised - -- file, if home && source + ms_imps :: [ModuleName], -- non-source imports + ms_hs_date :: Maybe ClockTime, -- timestamp of summarised + -- file, if home && source + ms_hi_date :: Maybe ClockTime -- timestamp of old iface, + -- if home && source } instance Outputable ModSummary where ppr ms - = sep [--text "ModSummary { ms_date = " <> text (show ms_date), - text "ModSummary {", - nest 3 (sep [text "ms_mod =" <+> ppr (ms_mod ms) <> comma, + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_hi_date = " <> text (show (ms_hi_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) <> comma, text "ms_imps =" <+> ppr (ms_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' ] +pprSummaryTimes ms + = sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_hi_date = " <> text (show (ms_hi_date ms))] + name_of_summary :: ModSummary -> ModuleName name_of_summary = moduleName . ms_mod \end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index af2a45b..e59a462 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -45,6 +45,9 @@ import Panic ( panic ) import Exception ( throwDyn ) import IO +import Time ( ClockTime ) +import Directory ( getModificationTime ) + \end{code} @@ -140,6 +143,12 @@ cmLoadModule cmstate1 rootname let pcii = pci pcms1 -- this never changes let ghci_mode = gmode pcms1 -- ToDo: fix! + -- During upsweep, look at new summaries to see if source has + -- changed. Here's a function to pass down; it takes a new + -- summary. + let source_changed :: ModSummary -> Bool + source_changed = summary_indicates_source_changed mg1 + -- 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. @@ -177,7 +186,7 @@ cmLoadModule cmstate1 rootname let threaded2 = CmThreaded pcs1 hst2 hit2 (upsweep_complete_success, threaded3, modsDone, newLis) - <- upsweep_mods ui2 threaded2 mg2 + <- upsweep_mods ghci_mode ui2 source_changed threaded2 mg2 let ui3 = add_to_ui ui2 newLis let (CmThreaded pcs3 hst3 hit3) = threaded3 @@ -245,6 +254,35 @@ cmLoadModule cmstate1 rootname else Just (last mods_to_keep_names)) +-- Given a bunch of old summaries and a new summary, try and +-- find the corresponding old summary, and, if found, compare +-- its source timestamp with that of the new summary. If in +-- doubt say True. +summary_indicates_source_changed :: [ModSummary] -> ModSummary -> Bool +summary_indicates_source_changed old_summaries new_summary + = case [old | old <- old_summaries, + name_of_summary old == name_of_summary new_summary] of + + (_:_:_) -> panic "summary_indicates_newer_source" + + [] -> -- can't find a corresponding old summary, so + -- compare source and iface dates in the new summary. + trace (showSDoc (text "SISC: no old summary, new =" + <+> pprSummaryTimes new_summary)) ( + case (ms_hs_date new_summary, ms_hi_date new_summary) of + (Just hs_t, Just hi_t) -> hs_t > hi_t + other -> True + ) + + [old] -> -- found old summary; compare source timestamps + trace (showSDoc (text "SISC: old =" + <+> pprSummaryTimes old + <+> pprSummaryTimes new_summary)) ( + case (ms_hs_date old, ms_hs_date new_summary) of + (Just old_t, Just new_t) -> new_t > old_t + other -> True + ) + -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName] @@ -266,6 +304,7 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest +-- Does this ModDetails export Main.main? exports_main :: ModDetails -> Bool exports_main md = maybeToBool (lookupNameEnv (md_types md) mainName) @@ -294,7 +333,9 @@ 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 :: UnlinkedImage -- old linkables +upsweep_mods :: GhciMode + -> UnlinkedImage -- old linkables + -> (ModSummary -> Bool) -- has source changed? -> CmThreaded -- PCS & HST & HIT -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... @@ -303,21 +344,22 @@ upsweep_mods :: UnlinkedImage -- old linkables [ModSummary], -- mods which succeeded [Linkable]) -- new linkables -upsweep_mods oldUI threaded [] +upsweep_mods ghci_mode oldUI source_changed threaded [] = return (True, threaded, [], []) -upsweep_mods oldUI threaded ((CyclicSCC ms):_) +upsweep_mods ghci_mode oldUI source_changed threaded ((CyclicSCC ms):_) = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.name_of_summary) ms)) return (False, threaded, [], []) -upsweep_mods oldUI threaded ((AcyclicSCC mod):mods) - = do (threaded1, maybe_linkable) <- upsweep_mod oldUI threaded mod +upsweep_mods ghci_mode oldUI source_changed threaded ((AcyclicSCC mod):mods) + = do (threaded1, maybe_linkable) + <- upsweep_mod ghci_mode oldUI threaded mod (source_changed mod) case maybe_linkable of Just linkable -> -- No errors; do the rest do (restOK, threaded2, modOKs, linkables) - <- upsweep_mods oldUI threaded1 mods + <- upsweep_mods ghci_mode oldUI source_changed threaded1 mods return (restOK, threaded2, mod:modOKs, linkable:linkables) Nothing -- we got a compilation error; give up now -> return (False, threaded1, [], []) @@ -325,16 +367,19 @@ upsweep_mods oldUI threaded ((AcyclicSCC mod):mods) -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: UnlinkedImage +upsweep_mod :: GhciMode + -> UnlinkedImage -> CmThreaded -> ModSummary + -> Bool -> IO (CmThreaded, Maybe Linkable) -upsweep_mod oldUI threaded1 summary1 +upsweep_mod ghci_mode oldUI threaded1 summary1 source_might_have_changed = do let mod_name = name_of_summary summary1 let (CmThreaded pcs1 hst1 hit1) = threaded1 let old_iface = lookupUFM hit1 (name_of_summary summary1) - compresult <- compile summary1 old_iface hst1 hit1 pcs1 + compresult <- compile ghci_mode summary1 (not source_might_have_changed) + old_iface hst1 hit1 pcs1 case compresult of @@ -363,6 +408,7 @@ upsweep_mod oldUI threaded1 summary1 in return (threaded2, Nothing) +-- Remove unwanted modules from the top level envs (HST, HIT, UI). removeFromTopLevelEnvs :: [ModuleName] -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) @@ -434,6 +480,7 @@ downsweep rootNm else loop (newHomeSummaries ++ homeSummaries) +-- Summarise a module, and pick and source and interface timestamps. summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location | isModuleInThisPackage mod @@ -442,14 +489,26 @@ summarise mod location modsrc <- readFile hspp_fn let (srcimps,imps) = getImports modsrc --- maybe_timestamp --- <- case ml_hs_file location of --- Nothing -> return Nothing --- Just src_fn -> getModificationTime src_fn >>= Just + maybe_src_timestamp + <- case ml_hs_file location of + Nothing -> return Nothing + Just src_fn -> maybe_getModificationTime src_fn + maybe_iface_timestamp + <- case ml_hi_file location of + Nothing -> return Nothing + Just if_fn -> maybe_getModificationTime if_fn return (ModSummary mod location{ml_hspp_file=Just hspp_fn} srcimps imps - {-maybe_timestamp-} ) + maybe_src_timestamp maybe_iface_timestamp) | otherwise - = return (ModSummary mod location [] []) + = return (ModSummary mod location [] [] Nothing Nothing) + + where + maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) + maybe_getModificationTime fn + = (do time <- getModificationTime fn + return (Just time)) + `catch` + (\err -> return Nothing) \end{code} diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index b6c213c..cab7b60 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.2 2000/11/13 14:34:37 sewardj Exp $ +-- $Id: DriverPhases.hs,v 1.3 2000/11/16 16:23:04 sewardj Exp $ -- -- GHC Driver -- @@ -47,7 +47,7 @@ data Phase | SplitAs | As | Ln - deriving (Eq) + deriving (Eq, Show) -- the first compilation phase for a given file is determined -- by its suffix. diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 8fe5de4..47535a6 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.27 2000/11/16 15:57:05 simonmar Exp $ +-- $Id: DriverPipeline.hs,v 1.28 2000/11/16 16:23:04 sewardj Exp $ -- -- GHC Driver -- @@ -22,6 +22,7 @@ module DriverPipeline ( #include "HsVersions.h" +import CmStaticInfo ( GhciMode(..) ) import CmTypes import GetImports import DriverState @@ -114,7 +115,7 @@ getGhcMode flags data IntermediateFileType = Temporary | Persistent - deriving (Eq) + deriving (Eq, Show) genPipeline :: GhcMode -- when to stop @@ -452,7 +453,8 @@ run_phase Hsc basename suff input_fn output_fn -- run the compiler! pcs <- initPersistentCompilerState - result <- hscMain dyn_flags{ hscOutName = output_fn } + result <- hscMain OneShot + dyn_flags{ hscOutName = output_fn } source_unchanged location Nothing -- no iface @@ -609,7 +611,7 @@ run_phase SplitMangle _basename _suff input_fn _output_fn -- As phase run_phase As _basename _suff input_fn output_fn - = do as <- readIORef v_Pgm_a + = do as <- readIORef v_Pgm_a as_opts <- getOpts opt_a cmdline_include_paths <- readIORef v_Include_paths @@ -740,7 +742,11 @@ preprocess filename = -- the .hs file if necessary, and compiling up the .stub_c files to -- generate Linkables. -compile :: ModSummary -- summary, including source +-- NB. No old interface can also mean that the source has changed. + +compile :: GhciMode -- distinguish batch from interactive + -> ModSummary -- summary, including source + -> Bool -- source unchanged? -> Maybe ModIface -- old interface, if available -> HomeSymbolTable -- for home module ModDetails -> HomeIfaceTable -- for home module Ifaces @@ -757,7 +763,7 @@ data CompResult | CompErrs PersistentCompilerState -- updated PCS -compile summary old_iface hst hit pcs = do +compile ghci_mode summary source_unchanged old_iface hst hit pcs = do verb <- readIORef v_Verbose when verb (hPutStrLn stderr (showSDoc (text "compile: compiling" @@ -784,8 +790,8 @@ compile summary old_iface hst hit pcs = do HscInterpreted -> return (error "no output file") -- run the compiler - hsc_result <- hscMain dyn_flags{ hscOutName = output_fn } - False -- (panic "compile:source_unchanged") + hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn } + source_unchanged location old_iface hst hit pcs case hsc_result of { @@ -818,7 +824,11 @@ compile summary old_iface hst hit pcs = do -- we're in batch mode: finish the compilation pipeline. _other -> do pipe <- genPipeline (StopBefore Ln) "" True hsc_lang output_fn - o_file <- runPipeline pipe output_fn False False + -- runPipeline takes input_fn so it can split off + -- the base name and use it as the base of + -- the output object file. + let (basename, suffix) = splitFilename input_fn + o_file <- pipeLoop pipe output_fn False False basename suffix return [ DotO o_file ] let linkable = LM (moduleName (ms_mod summary)) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index e1bfd15..108688e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -46,6 +46,7 @@ import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) import Outputable import Interpreter ( UnlinkedIBind, ItblEnv, stgToInterpSyn ) +import CmStaticInfo ( GhciMode(..) ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), PersistentRenamerState(..), ModuleLocation(..), @@ -82,7 +83,8 @@ data HscResult -- (parse/rename/typecheck) print messages themselves hscMain - :: DynFlags + :: GhciMode + -> DynFlags -> Bool -- source unchanged? -> ModuleLocation -- location info -> Maybe ModIface -- old interface, if available @@ -91,7 +93,7 @@ hscMain -> PersistentCompilerState -- IN: persistent compiler state -> IO HscResult -hscMain dflags source_unchanged location maybe_old_iface hst hit pcs +hscMain ghci_mode dflags source_unchanged location maybe_old_iface hst hit pcs = do { putStrLn ("CHECKING OLD IFACE for hs = " ++ show (ml_hs_file location) ++ ", hspp = " ++ show (ml_hspp_file location)); @@ -108,18 +110,24 @@ hscMain dflags source_unchanged location maybe_old_iface hst hit pcs what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp ; - what_next dflags location maybe_checked_iface + what_next ghci_mode dflags location maybe_checked_iface hst hit pcs_ch }} -hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch +-- we definitely expect to have the old interface available +hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch + | ghci_mode == OneShot + = return (HscOK + (panic "hscNoRecomp:OneShot") -- no details + Nothing -- makes run_phase Hsc stop + Nothing Nothing -- foreign export stuff + Nothing -- ibinds + pcs_ch) + | otherwise = do { hPutStrLn stderr "COMPILATION NOT REQUIRED"; - -- we definitely expect to have the old interface available - let old_iface = case maybe_checked_iface of - Just old_if -> old_if - Nothing -> panic "hscNoRecomp:old_iface" + let this_mod = mi_module old_iface ; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -150,7 +158,7 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch }}}} -hscRecomp dflags location maybe_checked_iface hst hit pcs_ch +hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch = do { ; hPutStrLn stderr "COMPILATION IS REQUIRED"; @@ -173,7 +181,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch <- renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { Nothing -> return (HscFail pcs_rn); - Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do { + Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do { ------------------- -- TYPECHECK