X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=da940adc4eb6e41afec412a70b52a2a3ee0c6ec6;hb=49ac6c398f2915de9eadff3cd2631bc31f806ec8;hp=dfaa2eb9b52b46330d7e8b113a566a1433a7cfca;hpb=37ad132b596204ce913a4c72905d6d06e32c0970;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index dfaa2eb..da940ad 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, partition ) +import List ( partition ) #include "../includes/config.h" @@ -104,7 +105,7 @@ import Foreign import CString ( CString, peekCString ) #endif -#if __GLASGOW_HASKELL__ < 601 +#if __GLASGOW_HASKELL__ < 603 import Foreign ( withMany, withArray0, nullPtr, Ptr ) import CForeign ( CString, withCString, throwErrnoIfMinus1 ) #else @@ -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 @@ -381,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 @@ -429,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 @@ -585,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} @@ -683,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) $ @@ -720,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 (real_pgm : argv)) $ do + exit_code <- rawSystem real_pgm argv if (exit_code /= ExitSuccess) then throwDyn (PhaseFailed phase_name exit_code) else return () @@ -749,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__ < 603 rawSystem :: FilePath -> [String] -> IO ExitCode @@ -776,10 +800,9 @@ foreign import ccall "rawSystem" unsafe -- 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 @@ -787,10 +810,25 @@ rawSystem cmd args = do n -> return (ExitFailure n) translate :: String -> String -translate str = '"' : foldr escape "\"" str - where escape '"' str = '\\' : '"' : str - escape '\\' str = '\\' : '\\' : str - escape c str = c : str +translate str@('"':_) = str -- already escaped. + -- ToDo: this case is wrong. It is only here because we + -- abuse the system in GHC's SysTools by putting arguments into + -- the command name; at some point we should fix it up and remove + -- the case above. +translate str = '"' : snd (foldr escape (True,"\"") str) + where escape '"' (b, str) = (True, '\\' : '"' : str) + escape '\\' (True, str) = (True, '\\' : '\\' : str) + escape '\\' (False, str) = (False, '\\' : str) + escape c (b, str) = (False, c : str) + -- This function attempts to invert the Microsoft C runtime's + -- quoting rules, which can be found here: + -- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp + -- (if this URL stops working, you might be able to find it by + -- searching for "Parsing C Command-Line Arguments" on MSDN). + -- + -- The Bool passed back along the string is True iff the + -- rest of the string is a sequence of backslashes followed by + -- a double quote. foreign import ccall "rawSystem" unsafe c_rawSystem :: CString -> IO Int @@ -819,12 +857,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 @@ -856,13 +890,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}