Fix -keep-s-file with --make

[ghc-hetmet.git] / compiler / main / SysTools.lhs

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 874387f..9885b8d 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -19,7 +19,8 @@ module SysTools (
        runMkDLL,
 
        touch,                  -- String -> String -> IO ()
-       copy,                   -- String -> String -> String -> IO ()
+       copy,
+        copyWithHeader,
        normalisePath,          -- FilePath -> FilePath
        
        -- Temporary-file management
@@ -51,7 +52,6 @@ import Data.IORef
 import Data.Int
 import Control.Monad
 import System.Exit
-import System.Cmd
 import System.Environment
 import System.IO
 import SYSTEM_IO_ERROR as IO
@@ -82,9 +82,11 @@ import Text.Regex
 
 #if __GLASGOW_HASKELL__ < 603
 -- rawSystem comes from libghccompat.a in stage1
-import Compat.RawSystem        ( rawSystem )
+import Compat.RawSystem ( rawSystem )
+import System.Cmd       ( system )
 import GHC.IOBase       ( IOErrorType(..) ) 
 #else
+import System.Cmd       ( rawSystem, system )
 import System.Process  ( runInteractiveProcess, getProcessExitCode )
 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
 import Data.Char        ( isSpace )
@@ -468,15 +470,21 @@ touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
 
-copy :: DynFlags -> String -> String -> String -> IO ()
-copy dflags purpose from to = do
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+               -> IO ()
+copyWithHeader dflags purpose maybe_header from to = do
   showPass dflags purpose
 
   h <- openFile to WriteMode
   ls <- readFile from -- inefficient, but it'll do for now.
                      -- ToDo: speed up via slurping.
+  maybe (return ()) (hPutStr h) maybe_header
   hPutStr h ls
   hClose h
+
 \end{code}
 
 %************************************************************************
@@ -493,22 +501,25 @@ GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
 \begin{code}
 cleanTempDirs :: DynFlags -> IO ()
 cleanTempDirs dflags
-   = do ds <- readIORef v_DirsToClean
+   = unless (dopt Opt_KeepTmpFiles dflags)
+   $ do ds <- readIORef v_DirsToClean
         removeTmpDirs dflags (eltsFM ds)
         writeIORef v_DirsToClean emptyFM
 
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
-   = do fs <- readIORef v_FilesToClean
-       removeTmpFiles dflags fs
-       writeIORef v_FilesToClean []
+   = unless (dopt Opt_KeepTmpFiles dflags)
+   $ do fs <- readIORef v_FilesToClean
+        removeTmpFiles dflags fs
+        writeIORef v_FilesToClean []
 
 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 cleanTempFilesExcept dflags dont_delete
-   = do files <- readIORef v_FilesToClean
-       let (to_keep, to_delete) = partition (`elem` dont_delete) files
-       removeTmpFiles dflags to_delete
-       writeIORef v_FilesToClean to_keep
+   = unless (dopt Opt_KeepTmpFiles dflags)
+   $ do files <- readIORef v_FilesToClean
+        let (to_keep, to_delete) = partition (`elem` dont_delete) files
+        removeTmpFiles dflags to_delete
+        writeIORef v_FilesToClean to_keep
 
 
 -- find a temporary name that doesn't already exist.