From: sewardj Date: Mon, 20 Nov 2000 13:39:26 +0000 (+0000) Subject: [project @ 2000-11-20 13:39:26 by sewardj] X-Git-Tag: Approximately_9120_patches~3310 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dd3c088ac501edf849b9cb8b929a3b51708f18b8;p=ghc-hetmet.git [project @ 2000-11-20 13:39:26 by sewardj] Redo the source-up-to-date logic (in CompManager.upsweep_mod). --- diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index f478dcc..cb3956b 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -64,7 +64,7 @@ data LinkResult findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable findModuleLinkable_maybe lis mod - = case [LM nm us | LM nm us <- lis, nm == mod] of + = case [LM time nm us | LM time nm us <- lis, nm == mod] of [] -> Nothing [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) @@ -124,7 +124,7 @@ link' Batch batch_attempt_linking linkables pls1 return (LinkOK pls1) where getOfiles (LP _) = panic "CmLink.link(getOfiles): shouldn't get package linkables" - getOfiles (LM _ us) = map nameOfObject (filter isObject us) + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) link' Interactive batch_attempt_linking linkables pls1 = linkObjs linkables pls1 @@ -134,11 +134,11 @@ ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC = ppr . flattenSCC -modname_of_linkable (LM nm _) = nm -modname_of_linkable (LP _) = panic "modname_of_linkable: package" +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 +is_package_linkable (LP _) = True +is_package_linkable (LM _ _ _) = False filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] @@ -146,8 +146,8 @@ filterModuleLinkables :: (ModuleName -> Bool) filterModuleLinkables p [] = [] filterModuleLinkables p (li:lis) = case li of - LP _ -> retain - LM modnm _ -> if p modnm then retain else dump + LP _ -> retain + LM _ modnm _ -> if p modnm then retain else dump where dump = filterModuleLinkables p lis retain = li : dump @@ -161,7 +161,7 @@ unload = panic "CmLink.unload: no interpreter" lookupClosure = panic "CmLink.lookupClosure: no interpreter" #else linkObjs [] pls = linkFinish pls [] [] -linkObjs (l@(LM _ uls) : ls) pls +linkObjs (l@(LM _ _ uls) : ls) pls | all isObject uls = do mapM_ loadObj [ file | DotO file <- uls ] linkObjs ls pls @@ -172,7 +172,7 @@ linkObjs _ pls = linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees -linkInterpretedCode (LM m uls : ls) mods ul_trees pls +linkInterpretedCode (LM _ m uls : ls) mods ul_trees pls | all isInterpretable uls = linkInterpretedCode ls (m:mods) (uls++ul_trees) pls diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs index 7332361..d2dfb1c 100644 --- a/ghc/compiler/compMan/CmTypes.lhs +++ b/ghc/compiler/compMan/CmTypes.lhs @@ -6,8 +6,8 @@ \begin{code} module CmTypes ( Unlinked(..), isObject, nameOfObject, isInterpretable, - Linkable(..), - ModSummary(..), name_of_summary, pprSummaryTimes + Linkable(..), linkableTime, + ModSummary(..), name_of_summary, pprSummaryTime ) where import Interpreter @@ -45,12 +45,19 @@ isInterpretable (Trees _ _) = True isInterpretable _ = False data Linkable - = LM ModuleName [Unlinked] + = LM ClockTime ModuleName [Unlinked] | LP PackageName instance Outputable Linkable where - ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds - ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm + 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 @@ -64,26 +71,22 @@ data ModSummary ms_location :: ModuleLocation, -- location ms_srcimps :: [ModuleName], -- source imports ms_imps :: [ModuleName], -- non-source imports - ms_hs_date :: Maybe ClockTime, -- timestamp of summarised + 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 {", 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))] +pprSummaryTime ms + = text "ms_hs_date = " <> parens (text (show (ms_hs_date ms))) name_of_summary :: ModSummary -> ModuleName name_of_summary = moduleName . ms_mod diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 15acd2b..eb19468 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -280,6 +280,8 @@ cmLoadModule cmstate1 rootname -- doubt say True. summary_indicates_source_changed :: [ModSummary] -> ModSummary -> Bool summary_indicates_source_changed old_summaries new_summary + = panic "SISC" +#if 0 = case [old | old <- old_summaries, name_of_summary old == name_of_summary new_summary] of @@ -302,6 +304,8 @@ summary_indicates_source_changed old_summaries new_summary (Just old_t, Just new_t) -> new_t > old_t other -> True ) +#endif + -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. @@ -394,6 +398,21 @@ upsweep_mods ghci_mode oldUI reachable_from source_changed 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 -> UnlinkedImage -> CmThreaded @@ -408,33 +427,42 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 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. Or if we're in interpretive - -- and there's no old linkable in oldUI. - compilation_mandatory - <- case ghci_mode of - Batch -> case ml_obj_file (ms_location summary1) of - Nothing -> return True - Just obj_fn -> do b <- doesFileExist obj_fn - return (not b) - Interactive -> case findModuleLinkable_maybe oldUI mod_name of - Nothing -> return True - Just li -> return False - OneShot -> panic "upsweep_mod:compilation_mandatory" - - let compilation_might_be_needed - = source_might_have_changed || compilation_mandatory + 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 + + -- 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_might_be_needed + = not compilation_mandatory + (hst1_strictDC, hit1_strictDC) = retainInTopLevelEnvs reachable_from_here (hst1,hit1) + old_linkable + = unJust "upsweep_mod:old_linkable" maybe_old_linkable + compresult <- compile ghci_mode summary1 source_unchanged old_iface hst1_strictDC hit1_strictDC pcs1 - --putStrLn ( "UPSWEEP_MOD: smhc = " ++ show source_might_have_changed - -- ++ ", cman = " ++ show compilation_mandatory) - case compresult of -- Compilation "succeeded", but didn't return a new iface or @@ -444,15 +472,6 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 -> let hst2 = addToUFM hst1 mod_name details hit2 = hit1 threaded2 = CmThreaded pcs2 hst2 hit2 - old_linkable - | ghci_mode == Interactive - = unJust "upsweep_mod(2)" - (findModuleLinkable_maybe oldUI mod_name) - | otherwise - = LM mod_name - [DotO (unJust "upsweep_mod(1)" - (ml_obj_file (ms_location summary1)) - )] in return (threaded2, Just old_linkable) -- Compilation really did happen, and succeeded. A new @@ -599,10 +618,6 @@ summarise mod location <- 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 -- If the module name is Main, allow it to be in a file -- different from Main.hs, and mash the mod and loc @@ -632,10 +647,10 @@ summarise mod location return (ModSummary mashed_mod mashed_loc{ml_hspp_file=Just hspp_fn} srcimps imps - maybe_src_timestamp maybe_iface_timestamp) + maybe_src_timestamp) | otherwise - = return (ModSummary mod location [] [] Nothing Nothing) + = return (ModSummary mod location [] [] Nothing) where maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index facd9ca..1d75248 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.31 2000/11/20 11:39:57 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.32 2000/11/20 13:39:26 sewardj Exp $ -- -- GHC Driver -- @@ -39,6 +39,7 @@ import CmdLineOpts import Config import Util +import Time ( getClockTime ) import Directory import System import IOExts @@ -816,15 +817,16 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do Nothing -> [] Just stub_o -> [ DotO stub_o ] - hs_unlinked <- + (hs_unlinked, unlinked_time) <- case hsc_lang of -- in interpreted mode, just return the compiled code -- as our "unlinked" object. HscInterpreted -> case maybe_interpreted_code of - Just (code,itbl_env) -> return [Trees code itbl_env] - Nothing -> panic "compile: no interpreted code" + Just (code,itbl_env) -> do tm <- getClockTime + return ([Trees code itbl_env], tm) + Nothing -> panic "compile: no interpreted code" -- we're in batch mode: finish the compilation pipeline. _other -> do pipe <- genPipeline (StopBefore Ln) "" True @@ -833,11 +835,13 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do -- 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 ] + o_file <- pipeLoop pipe output_fn False False + basename suffix + o_time <- getModificationTime o_file + return ([DotO o_file], o_time) - let linkable = LM (moduleName (ms_mod summary)) - (hs_unlinked ++ stub_unlinked) + let linkable = LM unlinked_time (moduleName (ms_mod summary)) + (hs_unlinked ++ stub_unlinked) return (CompOK details (Just (iface, linkable)) pcs) }