X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=e44ed6d7b3a8e27f67acf91439bd94d43faa8a65;hb=5ddee764beb312933256096d03df7c3ec47ac452;hp=fb9cf378044cbffd1725ca437cd871020d1016a9;hpb=d7fdebe8a174f968b63c98845cb16577e444ee13;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index fb9cf37..e44ed6d 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 () @@ -35,40 +31,32 @@ module SysTools ( -- System interface system, -- String -> IO ExitCode - -- Misc - getSysMan, -- IO String Parallel system only - Option(..) ) where #include "HsVersions.h" -import DriverPhases ( isHaskellUserSrcFilename ) +import DriverPhases import Config import Outputable -import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages ) -import Panic ( GhcException(..) ) -import Util ( Suffix, global, notNull, consIORef, joinFileName, - normalisePath, pgmPath, platformPath, joinFileExt ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..), - setTmpDir, defaultDynFlags ) - -import EXCEPTION ( throwDyn, finally ) -import DATA_IOREF ( IORef, readIORef, writeIORef ) -import DATA_INT - -import Monad ( when, unless ) -import System ( ExitCode(..), getEnv, system ) -import IO ( try, catch, hGetContents, - openFile, hPutStr, hClose, hFlush, IOMode(..), - stderr, ioError, isDoesNotExistError, - isAlreadyExistsError ) -import Directory ( doesFileExist, removeFile, - createDirectory, removeDirectory ) -import Maybe ( isJust ) -import List ( partition ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, eltsFM ) +import ErrUtils +import Panic +import Util +import DynFlags +import FiniteMap + +import Control.Exception +import Data.IORef +import Data.Int +import Control.Monad +import System.Exit +import System.Environment +import System.IO +import SYSTEM_IO_ERROR as IO +import System.Directory +import Data.Maybe +import Data.List -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command -- lines on mingw32, so we disallow it now. @@ -93,12 +81,12 @@ 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(..) ) -import System.IO.Error ( ioeGetErrorType ) #else +import System.Cmd ( rawSystem, system ) import System.Process ( runInteractiveProcess, getProcessExitCode ) -import System.IO ( hSetBuffering, hGetLine, BufferMode(..) ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) import Data.Char ( isSpace ) import FastString ( mkFastString ) @@ -168,34 +156,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} @@ -214,11 +174,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 @@ -368,19 +328,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 = "", @@ -389,7 +341,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) @@ -509,9 +466,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 @@ -522,22 +478,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 @@ -552,22 +494,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.