X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=da940adc4eb6e41afec412a70b52a2a3ee0c6ec6;hb=49ac6c398f2915de9eadff3cd2631bc31f806ec8;hp=e5fafdd8c551d7dab0727a4004555d726b641568;hpb=536e2a029dcc11c33c9448146b34513c682f17ad;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index e5fafdd..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,11 +65,11 @@ module SysTools ( #include "HsVersions.h" import DriverUtil -import DriverPhases ( haskellish_user_src_file ) +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 ) @@ -77,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" @@ -105,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 @@ -204,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 @@ -254,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 @@ -382,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 @@ -430,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 @@ -586,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} @@ -651,15 +644,17 @@ setTmpDir dir = writeIORef v_TmpDir (canonicalise dir) #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. @@ -699,7 +694,7 @@ removeTmpFiles verb fs hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees) act - (non_deletees, deletees) = partition haskellish_user_src_file fs + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs rm f = removeFile f `IO.catch` (\_ignored -> @@ -734,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 () @@ -763,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 @@ -790,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 @@ -801,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 @@ -833,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 @@ -870,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}