[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.

ghc/compiler/ghci/Linker.lhs

 %
-% (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

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 ..."

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

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,

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

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}
@@ -839,6 +842,16 @@ handle h f = f `Exception.catch` \e -> case e of
     _               -> h e
 #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