X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=fb9cf378044cbffd1725ca437cd871020d1016a9;hb=d7fdebe8a174f968b63c98845cb16577e444ee13;hp=eee3e1a38354a3e6b511288663466fb186dfb66b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index eee3e1a..fb9cf37 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -29,7 +29,7 @@ module SysTools (
 	-- Temporary-file management
 	setTmpDir,
 	newTempName,
-	cleanTempFiles, cleanTempFilesExcept,
+	cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
 	addFilesToClean,
 
 	-- System interface
@@ -62,10 +62,13 @@ import Monad		( when, unless )
 import System		( ExitCode(..), getEnv, system )
 import IO		( try, catch, hGetContents,
 			  openFile, hPutStr, hClose, hFlush, IOMode(..), 
-			  stderr, ioError, isDoesNotExistError )
-import Directory	( doesFileExist, removeFile )
+			  stderr, ioError, isDoesNotExistError,
+			  isAlreadyExistsError )
+import Directory	( doesFileExist, removeFile,
+			  createDirectory, removeDirectory )
 import Maybe		( isJust )
 import List             ( partition )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, eltsFM )
 
 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
 -- lines on mingw32, so we disallow it now.
@@ -543,9 +546,16 @@ getUsageMsgPaths = readIORef v_Path_usages
 
 \begin{code}
 GLOBAL_VAR(v_FilesToClean, [],               [String] )
+GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
 \end{code}
 
 \begin{code}
+cleanTempDirs :: DynFlags -> IO ()
+cleanTempDirs dflags
+   = do ds <- readIORef v_DirsToClean
+        removeTmpDirs dflags (eltsFM ds)
+        writeIORef v_DirsToClean emptyFM
+
 cleanTempFiles :: DynFlags -> IO ()
 cleanTempFiles dflags
    = do fs <- readIORef v_FilesToClean
@@ -562,9 +572,10 @@ cleanTempFilesExcept dflags dont_delete
 
 -- find a temporary name that doesn't already exist.
 newTempName :: DynFlags -> Suffix -> IO FilePath
-newTempName DynFlags{tmpDir=tmp_dir} extn
-  = do x <- getProcessID
-       findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
+newTempName dflags extn
+  = do d <- getTempDir dflags
+       x <- getProcessID
+       findTempName (d ++ "/ghc" ++ show x ++ "_") 0
   where 
     findTempName prefix x
       = do let filename = (prefix ++ show x) `joinFileExt` extn
@@ -573,16 +584,45 @@ newTempName DynFlags{tmpDir=tmp_dir} extn
 		else do consIORef v_FilesToClean filename -- clean it up later
 		        return filename
 
+-- return our temporary directory within tmp_dir, creating one if we
+-- don't have one yet
+getTempDir :: DynFlags -> IO FilePath
+getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
+  = do mapping <- readIORef v_DirsToClean
+       case lookupFM mapping tmp_dir of
+           Nothing ->
+               do x <- getProcessID
+                  let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+                      mkTempDir x
+                       = let dirname = prefix ++ show x
+                         in do createDirectory dirname
+                               let mapping' = addToFM mapping tmp_dir dirname
+                               writeIORef v_DirsToClean mapping'
+                               debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
+                               return dirname
+                            `IO.catch` \e ->
+                                    if isAlreadyExistsError e
+                                    then mkTempDir (x+1)
+                                    else ioError e
+                  mkTempDir 0
+           Just d -> return d
+
 addFilesToClean :: [FilePath] -> IO ()
 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
 
+removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
+removeTmpDirs dflags ds
+  = traceCmd dflags "Deleting temp dirs"
+	     ("Deleting: " ++ unwords ds)
+	     (mapM_ (removeWith dflags removeDirectory) ds)
+
 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 removeTmpFiles dflags fs
   = warnNon $
     traceCmd dflags "Deleting temp files" 
 	     ("Deleting: " ++ unwords deletees)
-	     (mapM_ rm deletees)
+	     (mapM_ (removeWith dflags removeFile) deletees)
   where
      -- Flat out refuse to delete files that are likely to be source input
      -- files (is there a worse bug than having a compiler delete your source
@@ -598,11 +638,16 @@ removeTmpFiles dflags fs
 
     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 
-    rm f = removeFile f `IO.catch` 
-		(\_ignored -> 
-		    debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
-		)
-
+removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
+removeWith dflags remover f = remover f `IO.catch`
+  (\e ->
+   let msg = if isDoesNotExistError e
+             then ptext SLIT("Warning: deleting non-existent") <+> text f
+             else ptext SLIT("Warning: exception raised when deleting")
+                                            <+> text f <> colon
+               $$ text (show e)
+   in debugTraceMsg dflags 2 msg
+  )
 
 -----------------------------------------------------------------------------
 -- Running an external program
@@ -704,7 +749,7 @@ builderMainLoop dflags filter_fn pgm real_args = do
 
 readerProc chan hdl filter_fn =
     (do str <- hGetContents hdl
-        loop (lines (filter_fn str)) Nothing) 
+        loop (linesPlatform (filter_fn str)) Nothing) 
     `finally`
        writeChan chan EOF
 	-- ToDo: check errors more carefully
@@ -814,4 +859,22 @@ getProcessID :: IO Int
 getProcessID = Posix.getProcessID
 #endif
 
+-- Divvy up text stream into lines, taking platform dependent
+-- line termination into account.
+linesPlatform :: String -> [String]
+#if !defined(mingw32_HOST_OS)
+linesPlatform ls = lines ls
+#else
+linesPlatform "" = []
+linesPlatform xs = 
+  case lineBreak xs of
+    (as,xs1) -> as : linesPlatform xs1
+  where
+   lineBreak "" = ("","")
+   lineBreak ('\r':'\n':xs) = ([],xs)
+   lineBreak ('\n':xs) = ([],xs)
+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
+
+#endif
+
 \end{code}