X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=7d933c1ac64229c05afc2d325023c4cf13d4ad7f;hb=4a9c5b7e6425015827cd71815a829fde34ebe73e;hp=f9138cdf2e0b126bad36de3771a72f66351ac744;hpb=c447b9e272c0b2cfc3a15cc890e40daf7a500b8d;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index f9138cd..7d933c1 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- (c) The University of Glasgow 2001 +-- (c) The University of Glasgow 2001-2003 -- -- Access to system tools: gcc, cp, rm etc -- @@ -19,6 +19,7 @@ module SysTools ( setPgms, setPgma, setPgml, + setPgmDLL, #ifdef ILX setPgmI, setPgmi, @@ -28,6 +29,7 @@ module SysTools ( getTopDir, -- IO String -- The value of $libdir getPackageConfigPath, -- IO String -- Where package.conf is + getUsageMsgPaths, -- IO (String,String) -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () @@ -47,15 +49,13 @@ module SysTools ( -- Temporary-file management setTmpDir, newTempName, - cleanTempFiles, cleanTempFilesExcept, removeTmpFiles, + cleanTempFiles, cleanTempFilesExcept, addFilesToClean, -- System interface - getProcessID, -- IO Int system, -- String -> IO ExitCode -- Misc - showGhcUsage, -- IO () Shows usage message and exits getSysMan, -- IO String Parallel system only Option(..) @@ -65,10 +65,11 @@ module SysTools ( #include "HsVersions.h" import DriverUtil +import DriverPhases ( isHaskellUserSrcFilename ) import Config import Outputable -import Panic ( progName, GhcException(..) ) -import Util ( global, notNull ) +import Panic ( GhcException(..) ) +import Util ( global, notNull, toArgs ) import CmdLineOpts ( dynFlag, verbosity ) import EXCEPTION ( throwDyn ) @@ -76,12 +77,12 @@ import DATA_IOREF ( IORef, readIORef, writeIORef ) import DATA_INT import Monad ( when, unless ) -import System ( ExitCode(..), exitWith, getEnv, system ) +import System ( ExitCode(..), getEnv, system ) import IO ( try, catch, - openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..), + openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..), stderr ) import Directory ( doesFileExist, removeFile ) -import List ( intersperse ) +import List ( partition ) #include "../includes/config.h" @@ -203,7 +204,7 @@ 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_usage, error "ghc_usage.txt", String) +GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String)) GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B @@ -253,6 +254,10 @@ initSysTools minusB_args | am_installed = installed "ghc-usage.txt" | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" + ghci_usage_msg_path + | am_installed = installed "ghci-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt" + -- For all systems, unlit, split, mangle are GHC utilities -- architecture-specific stuff is done when building Config.hs unlit_path @@ -278,30 +283,21 @@ initSysTools minusB_args -- On Win32, consult GetTempPath() for a temp dir. -- => it first tries TMP, TEMP, then finally the -- Windows directory(!). The directory is in short-path - -- form and *does* have a trailing backslash. + -- form. ; IO.try (do let len = (2048::Int) buf <- mallocArray len ret <- getTempPath len buf tdir <- if ret == 0 then do - -- failed, consult TEMP. + -- failed, consult TMPDIR. free buf - getEnv "TMP" + getEnv "TMPDIR" else do s <- peekCString buf free buf return s - let - -- strip the trailing backslash (awful, but - -- we only do this once). - tmpdir = - case last tdir of - '/' -> init tdir - '\\' -> init tdir - _ -> tdir - setTmpDir tmpdir - return ()) + setTmpDir tdir) #endif -- Check that the package config exists @@ -390,7 +386,8 @@ initSysTools minusB_args -- Initialise the global vars ; writeIORef v_Path_package_config pkgconfig_path - ; writeIORef v_Path_usage ghc_usage_msg_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 @@ -438,6 +435,7 @@ setPgmm = writeIORef v_Pgm_m setPgms = writeIORef v_Pgm_s setPgma = writeIORef v_Pgm_a setPgml = writeIORef v_Pgm_l +setPgmDLL = writeIORef v_Pgm_MkDLL #ifdef ILX setPgmI = writeIORef v_Pgm_I setPgmi = writeIORef v_Pgm_i @@ -594,23 +592,10 @@ getSysMan :: IO String -- How to invoke the system manager getSysMan = readIORef v_Pgm_sysman \end{code} -%************************************************************************ -%* * -\subsection{GHC Usage message} -%* * -%************************************************************************ - -Show the usage message and exit - \begin{code} -showGhcUsage = do { usage_path <- readIORef v_Path_usage - ; usage <- readFile usage_path - ; dump usage - ; exitWith ExitSuccess } - where - dump "" = return () - dump ('$':'$':s) = hPutStr stderr progName >> dump s - dump (c:s) = hPutChar stderr c >> dump s +getUsageMsgPaths :: IO (FilePath,FilePath) + -- the filenames of the usage messages (ghc, ghci) +getUsageMsgPaths = readIORef v_Path_usages \end{code} @@ -627,18 +612,49 @@ GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String ) \end{code} \begin{code} -setTmpDir dir = writeIORef v_TmpDir dir +setTmpDir dir = writeIORef v_TmpDir (canonicalise dir) + where +#if !defined(mingw32_HOST_OS) + canonicalise p = normalisePath p +#else + -- Canonicalisation of temp path under win32 is a bit more + -- involved: (a) strip trailing slash, + -- (b) normalise slashes + -- (c) just in case, if there is a prefix /cygdrive/x/, change to x: + -- + canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path)) + + -- if we're operating under cygwin, and TMP/TEMP is of + -- the form "/cygdrive/drive/path", translate this to + -- "drive:/path" (as GHC isn't a cygwin app and doesn't + -- understand /cygdrive paths.) + xltCygdrive path + | "/cygdrive/" `isPrefixOf` path = + case drop (length "/cygdrive/") path of + drive:xs@('/':_) -> drive:':':xs + _ -> path + | otherwise = path + + -- strip the trailing backslash (awful, but we only do this once). + removeTrailingSlash path = + case last path of + '/' -> init path + '\\' -> init path + _ -> path +#endif cleanTempFiles :: Int -> IO () -cleanTempFiles verb = do fs <- readIORef v_FilesToClean - removeTmpFiles verb fs +cleanTempFiles verb + = do fs <- readIORef v_FilesToClean + removeTmpFiles verb fs + writeIORef v_FilesToClean [] 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 + = do files <- readIORef v_FilesToClean + let (to_keep, to_delete) = partition (`elem` dont_delete) files + removeTmpFiles verb to_delete + writeIORef v_FilesToClean to_keep -- find a temporary name that doesn't already exist. @@ -661,10 +677,25 @@ addFilesToClean files = mapM_ (add v_FilesToClean) files removeTmpFiles :: Int -> [FilePath] -> IO () removeTmpFiles verb fs - = traceCmd "Deleting temp files" - ("Deleting: " ++ unwords fs) - (mapM_ rm fs) + = warnNon $ + traceCmd "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ rm 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 + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + rm f = removeFile f `IO.catch` (\_ignored -> when (verb >= 2) $ @@ -698,8 +729,14 @@ runSomething :: String -- For -v message runSomething phase_name pgm args = do let real_args = filter notNull (map showOpt args) - traceCmd phase_name (concat (intersperse " " (pgm:real_args))) $ do - exit_code <- rawSystem pgm real_args + -- Don't assume that 'pgm' contains the program path only, + -- but split it up and shift any arguments over to the arg vector. + let (real_pgm, argv) = + case toArgs pgm of + [] -> (pgm, real_args) -- let rawSystem be the bearer of bad news.. + (x:xs) -> (x, xs ++ real_args) + traceCmd phase_name (unwords (pgm:real_args)) $ do + exit_code <- rawSystem real_pgm argv if (exit_code /= ExitSuccess) then throwDyn (PhaseFailed phase_name exit_code) else return () @@ -727,10 +764,19 @@ traceCmd phase_name cmd_line action -- ----------------------------------------------------------------------------- -- rawSystem: run an external command +-- +-- In GHC 6.2.1 there's a correct implementation of rawSystem in the +-- library System.Cmd. If we are compiling with an earlier version of +-- GHC than this, we'd better have a copy of the correct implementation +-- right here. -#if __GLASGOW_HASKELL__ < 601 +-- If you ever alter this code, you must alter +-- libraries/base/System/Cmd.hs +-- at the same time! There are also exensive comments in System.Cmd +-- thare are not repeated here -- go look! --- This code is copied from System.Cmd on GHC 6.1. + +#if __GLASGOW_HASKELL__ < 621 rawSystem :: FilePath -> [String] -> IO ExitCode @@ -745,7 +791,7 @@ rawSystem cmd args = 0 -> return ExitSuccess n -> return (ExitFailure n) -foreign import ccall unsafe "rawSystem" +foreign import ccall "rawSystem" unsafe c_rawSystem :: CString -> Ptr CString -> IO Int #else @@ -754,10 +800,9 @@ foreign import ccall unsafe "rawSystem" -- a single string. Command-line parsing is done by the executable -- itself. rawSystem cmd args = do - let cmdline = {-translate-} cmd ++ concat (map ((' ':) . translate) args) - -- Urk, don't quote/escape the command name on Windows, because the - -- compiler is exceedingly naughty and sometimes uses 'perl "..."' - -- as the command name. + -- NOTE: 'cmd' is assumed to contain the application to run _only_, + -- as it'll be quoted surrounded in quotes here. + let cmdline = translate cmd ++ concat (map ((' ':) . translate) args) withCString cmdline $ \pcmdline -> do status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline) case status of @@ -765,12 +810,18 @@ rawSystem cmd args = do n -> return (ExitFailure n) translate :: String -> String +-- Returns a string wrapped in double-quotes +-- If the input string starts with double-quote, don't touch it +-- If not, wrap it in double-quotes and double any backslashes +-- foo\baz --> "foo\\baz" +-- "foo\baz" --> "foo\baz" + +translate str@('"':_) = str -- already escaped. translate str = '"' : foldr escape "\"" str where escape '"' str = '\\' : '"' : str - escape '\\' str = '\\' : '\\' : str escape c str = c : str -foreign import ccall unsafe "rawSystem" +foreign import ccall "rawSystem" unsafe c_rawSystem :: CString -> IO Int #endif @@ -797,12 +848,8 @@ interpreted a command line 'foo\baz' as 'foobaz'. ----------------------------------------------------------------------------- -- Convert filepath into platform / MSDOS form. --- platformPath does two things --- a) change '/' to '\' --- b) remove initial '/cygdrive/' - normalisePath :: String -> String --- Just change '\' to '/' +-- Just changes '\' to '/' pgmPath :: String -- Directory string in Unix format -> String -- Program name with no directory separators @@ -834,13 +881,6 @@ platformPath stuff = stuff \begin{code} slash :: String -> String -> String -absPath, relPath :: [String] -> String - -relPath [] = "" -relPath xs = foldr1 slash xs - -absPath xs = "" `slash` relPath xs - slash s1 s2 = s1 ++ ('/' : s2) \end{code}