From a25955b5ac32b2a501c7278acb39cfeccd308a6f Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 12 Feb 2001 13:33:47 +0000
Subject: [PATCH] [project @ 2001-02-12 13:33:46 by simonmar] Clean up
 temporary files between compilations, but cache
 preprocessed modules that we might re-use.

---
 ghc/compiler/compMan/CompManager.lhs |   11 ++++++++++
 ghc/compiler/main/Main.hs            |    4 ++--
 ghc/compiler/main/TmpFiles.hs        |   38 +++++++++++++++++++++++-----------
 3 files changed, 39 insertions(+), 14 deletions(-)

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 09f1db8..f136af7 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -36,6 +36,7 @@ import DriverUtil	( splitFilename3 )
 import ErrUtils		( showPass )
 import Util
 import DriverUtil
+import TmpFiles
 import Outputable
 import Panic
 import CmdLineOpts	( DynFlags(..) )
@@ -284,6 +285,10 @@ cmLoadModule cmstate1 rootname
            -- Easy; just relink it all.
            do when (verb >= 2) $ 
 		 hPutStrLn stderr "Upsweep completely successful."
+
+	      -- clean up after ourselves
+	      cleanTempFilesExcept verb (ppFilesFromSummaries modsDone)
+
               linkresult 
                  <- link ghci_mode dflags a_root_is_Main ui3 pls2
               case linkresult of
@@ -321,6 +326,9 @@ cmLoadModule cmstate1 rootname
                      = map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4)
                            mods_to_keep_names
 
+	      -- clean up after ourselves
+	      cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
+
               linkresult <- link ghci_mode dflags False linkables_to_link pls2
               case linkresult of
                  LinkErrs _ _
@@ -334,6 +342,9 @@ cmLoadModule cmstate1 rootname
                                   map ms_mod mods_to_keep)
 
 
+ppFilesFromSummaries summaries
+  = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ]
+
 -----------------------------------------------------------------------------
 -- getValidLinkables
 
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 51e5e47..263f49d 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.49 2001/01/21 16:37:06 sewardj Exp $
+-- $Id: Main.hs,v 1.50 2001/02/12 13:33:46 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -103,7 +103,7 @@ main =
    later (do  forget_it <- readIORef v_Keep_tmp_files
 	      unless forget_it $ do
 	      verb <- dynFlag verbosity
-	      cleanTempFiles (verb >= 2)
+	      cleanTempFiles verb
      ) $ do
 	-- exceptions will be blocked while we clean the temporary files,
 	-- so there shouldn't be any difficulty if we receive further
diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs
index 5bd5e59..2a6eb7f 100644
--- a/ghc/compiler/main/TmpFiles.hs
+++ b/ghc/compiler/main/TmpFiles.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.14 2000/12/11 15:26:00 sewardj Exp $
+-- $Id: TmpFiles.hs,v 1.15 2001/02/12 13:33:47 simonmar Exp $
 --
 -- Temporary file management
 --
@@ -10,9 +10,11 @@
 module TmpFiles (
    Suffix,
    initTempFileStorage,  -- :: IO ()
-   cleanTempFiles,       -- :: IO ()
+   cleanTempFiles,       -- :: Int -> IO ()
+   cleanTempFilesExcept, -- :: Int -> [FilePath] -> IO ()
    newTempName,		 -- :: Suffix -> IO FilePath
    addFilesToClean,	 -- :: [FilePath] -> IO ()
+   removeTmpFiles,	 -- :: Int -> [FilePath] -> IO ()
    v_TmpDir
  ) where
 
@@ -46,18 +48,17 @@ initTempFileStorage = do
 	      return ()
           )
 
-cleanTempFiles :: Bool -> IO ()
-cleanTempFiles verbose = do
+cleanTempFiles :: Int -> IO ()
+cleanTempFiles verb = do
   fs <- readIORef v_FilesToClean
+  removeTmpFiles verb fs
 
-  let blowAway f =
-	   (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
-		if '*' `elem` f then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
-			        else removeFile f)
-	    `catchAllIO`
-	   (\_ -> when verbose (hPutStrLn stderr 
-				("Warning: can't remove tmp file " ++ f)))
-  mapM_ blowAway fs
+cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
+cleanTempFilesExcept verb dont_delete = do
+  fs <- readIORef v_FilesToClean
+  let leftovers = filter (`notElem` dont_delete) fs
+  removeTmpFiles verb leftovers
+  writeIORef v_FilesToClean dont_delete
 
 type Suffix = String
 
@@ -76,3 +77,16 @@ newTempName extn = do
 
 addFilesToClean :: [FilePath] -> IO ()
 addFilesToClean files = mapM_ (add v_FilesToClean) files
+
+removeTmpFiles :: Int -> [FilePath] -> IO ()
+removeTmpFiles verb fs = do
+  let verbose = verb >= 2
+      blowAway f =
+	   (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
+		if '*' `elem` f 
+		  then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
+		  else removeFile f)
+	    `catchAllIO`
+	   (\_ -> when verbose (hPutStrLn stderr 
+				("Warning: can't remove tmp file " ++ f)))
+  mapM_ blowAway fs
-- 
1.7.10.4