X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=594407e766d2ec210ffc87bd4f3ab5b07f4e78dd;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hp=4e5c5834fb4ae734964f5699c1a2cf0905a87c2b;hpb=6ec1fb0666d5493c236f856e8512a78700dd2b07;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 4e5c583..594407e 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -11,10 +11,6 @@ module SysTools ( -- Initialisation initSysTools, - getTopDir, -- IO String -- The value of $topdir - getPackageConfigPath, -- IO String -- Where package.conf is - getUsageMsgPaths, -- IO (String,String) - -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () @@ -29,15 +25,12 @@ module SysTools ( -- Temporary-file management setTmpDir, newTempName, - cleanTempFiles, cleanTempFilesExcept, + cleanTempDirs, cleanTempFiles, cleanTempFilesExcept, addFilesToClean, -- System interface system, -- String -> IO ExitCode - -- Misc - getSysMan, -- IO String Parallel system only - Option(..) ) where @@ -62,10 +55,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. @@ -165,34 +161,6 @@ stuff. End of NOTES --------------------------------------------- - -%************************************************************************ -%* * -\subsection{Global variables to contain system programs} -%* * -%************************************************************************ - -All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE. -(See remarks under pathnames below) - -\begin{code} -GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch -GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp - -GLOBAL_VAR(v_Path_package_config, error "path_package_config", String) -GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String)) - -GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B - --- Parallel system only -GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager - --- ways to get at some of these variables from outside this module -getPackageConfigPath = readIORef v_Path_package_config -getTopDir = readIORef v_TopDir -\end{code} - - %************************************************************************ %* * \subsection{Initialisation} @@ -211,11 +179,11 @@ initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) initSysTools mbMinusB dflags = do { (am_installed, top_dir) <- findTopDir mbMinusB - ; writeIORef v_TopDir top_dir -- top_dir -- for "installed" this is the root of GHC's support files -- for "in-place" it is the root of the build tree - -- NB: top_dir is assumed to be in standard Unix format '/' separated + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated ; let installed, installed_bin :: FilePath -> FilePath installed_bin pgm = pgmPath top_dir pgm @@ -365,19 +333,11 @@ initSysTools mbMinusB dflags ; let (as_prog,as_args) = (gcc_prog,gcc_args) (ld_prog,ld_args) = (gcc_prog,gcc_args) - -- Initialise the global vars - ; writeIORef v_Path_package_config pkgconfig_path - ; writeIORef v_Path_usages (ghc_usage_msg_path, - ghci_usage_msg_path) - - ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan") - -- Hans: this isn't right in general, but you can - -- elaborate it in the same way as the others - - ; writeIORef v_Pgm_T touch_path - ; writeIORef v_Pgm_CP cp_path - ; return dflags1{ + ghcUsagePath = ghc_usage_msg_path, + ghciUsagePath = ghci_usage_msg_path, + topDir = top_dir, + systemPackageConfig = pkgconfig_path, pgm_L = unlit_path, pgm_P = cpp_path, pgm_F = "", @@ -386,7 +346,12 @@ initSysTools mbMinusB dflags pgm_s = (split_prog,split_args), pgm_a = (as_prog,as_args), pgm_l = (ld_prog,ld_args), - pgm_dll = (mkdll_prog,mkdll_args) } + pgm_dll = (mkdll_prog,mkdll_args), + pgm_T = touch_path, + pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan" + -- Hans: this isn't right in general, but you can + -- elaborate it in the same way as the others + } } #if defined(mingw32_HOST_OS) @@ -506,9 +471,8 @@ runMkDLL dflags args = do runSomething dflags "Make DLL" p (args0++args) touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = do - p <- readIORef v_Pgm_T - runSomething dflags purpose p [FileOption "" arg] +touch dflags purpose arg = + runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] copy :: DynFlags -> String -> String -> String -> IO () copy dflags purpose from to = do @@ -519,22 +483,8 @@ copy dflags purpose from to = do -- ToDo: speed up via slurping. hPutStr h ls hClose h - -\end{code} - -\begin{code} -getSysMan :: IO String -- How to invoke the system manager - -- (parallel system only) -getSysMan = readIORef v_Pgm_sysman \end{code} -\begin{code} -getUsageMsgPaths :: IO (FilePath,FilePath) - -- the filenames of the usage messages (ghc, ghci) -getUsageMsgPaths = readIORef v_Path_usages -\end{code} - - %************************************************************************ %* * \subsection{Managing temporary files @@ -543,9 +493,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 +519,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 +531,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 +585,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