X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=392b9b220443721e4e740d9738245d5ef7c255db;hb=301ba995afdbaf31dfcd9f5c4cc6048e6cd2fda8;hp=3b0bfba18466ffc5c09e69518aa7cd4131fbdfc1;hpb=805763442ddfe7e3470b643a73cac66855a830f5;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 3b0bfba..392b9b2 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -33,12 +33,11 @@ module SysTools ( -- System interface getProcessID, -- IO Int - System.system, -- String -> IO Int -- System.system + system, -- String -> IO Int -- Misc showGhcUsage, -- IO () Shows usage message and exits getSysMan, -- IO String Parallel system only - dosifyPath, -- String -> String runSomething -- ToDo: make private ) where @@ -50,9 +49,10 @@ import Panic ( progName, GhcException(..) ) import Util ( global ) import CmdLineOpts ( dynFlag, verbosity ) -import List ( intersperse ) -import Exception ( throwDyn, catchAllIO ) +import List ( isPrefixOf ) +import Exception ( throw, throwDyn, catchAllIO ) import IO ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr ) +import IO ( openFile, IOMode(..), hClose ) -- For temp "system" import Directory ( doesFileExist, removeFile ) import IOExts ( IORef, readIORef, writeIORef ) import Monad ( when, unless ) @@ -118,6 +118,9 @@ Config.hs contains two sorts of things %* * %************************************************************************ +All these pathnames are maintained in Unix format. +(See remarks under pathnames below) + \begin{code} GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp @@ -312,32 +315,33 @@ getTopDir :: [String] String) -- TopDir getTopDir minusbs - = do { proto_top_dir <- get_proto + = do { top_dir1 <- get_proto + ; let top_dir2 = unDosifyPath top_dir1 -- Convert to standard internal form -- Discover whether we're running in a build tree or in an installation, -- by looking for the package configuration file. - ; am_installed <- doesFileExist (proto_top_dir `slash` "package.conf") + ; am_installed <- doesFileExist (top_dir2 `slash` "package.conf") ; if am_installed then - return (True, proto_top_dir) + return (True, top_dir2) else - return (False, remove_suffix proto_top_dir) + return (False, remove_suffix top_dir2) } where get_proto | not (null minusbs) - = return (dosifyPath (drop 2 (last minusbs))) + = return (drop 2 (last minusbs)) -- 2 for "-B" | otherwise = do { maybe_exec_dir <- getExecDir -- Get directory of executable - ; case maybe_exec_dir of -- (only works on Windows) - Nothing -> throwDyn (InstallationError - "missing -B option") + ; case maybe_exec_dir of -- (only works on Windows; + -- returns Nothing on Unix) + Nothing -> throwDyn (InstallationError "missing -B option") Just dir -> return dir } remove_suffix dir -- "/...stuff.../ghc/compiler" --> "/...stuff..." = ASSERT2( not (null p1) && not (null p2) && - dosifyPath dir == dosifyPath (top_dir ++ "/ghc/compiler"), + dir == top_dir ++ "/ghc/compiler", text dir ) top_dir where @@ -475,7 +479,7 @@ addFilesToClean files = mapM_ (add v_FilesToClean) files removeTmpFiles :: Int -> [FilePath] -> IO () removeTmpFiles verb fs = traceCmd "Deleting temp files" - ("Deleting: " ++ concat (intersperse " " fs)) + ("Deleting: " ++ unwords fs) (mapM_ rm fs) where rm f = removeFile f `catchAllIO` @@ -509,13 +513,19 @@ runSomething :: String -- For -v message runSomething phase_name pgm args = traceCmd phase_name cmd_line $ - do { exit_code <- System.system cmd_line + do { exit_code <- system cmd_line ; if exit_code /= ExitSuccess then throwDyn (PhaseFailed phase_name exit_code) else return () } where - cmd_line = unwords (pgm : dosifyPaths args) +-- Don't convert paths to DOS format when using the kludged +-- version of 'system' on mingw32. See comments with 'system' below. +#if __GLASGOW_HASKELL__ > 501 + cmd_line = unwords (dosifyPaths (pgm : args)) +#else + cmd_line = unwords (pgm : args) +#endif traceCmd :: String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity) @@ -542,22 +552,37 @@ traceCmd phase_name cmd_line action %************************************************************************ %* * -\subsection{Support code} +\subsection{Path names} %* * %************************************************************************ +We maintain path names in Unix form ('/'-separated) right until +the last moment. On Windows we dos-ify them just before passing them +to the Windows command. + +The alternative, of using '/' consistently on Unix and '\' on Windows, +proved quite awkward. There were a lot more calls to dosifyPath, +and even on Windows we might invoke a unix-like utility (eg 'sh'), which +interpreted a command line 'foo\baz' as 'foobaz'. \begin{code} ----------------------------------------------------------------------------- -- Convert filepath into MSDOS form. -dosifyPaths :: [String] -> [String] dosifyPath :: String -> String +dosifyPaths :: [String] -> [String] -- dosifyPath does two things -- a) change '/' to '\' -- b) remove initial '/cygdrive/' +unDosifyPath :: String -> String +-- Just change '\' to '/' + #if defined(mingw32_TARGET_OS) + +--------------------- Windows version ------------------ +unDosifyPath xs = xs + dosifyPaths xs = map dosifyPath xs dosifyPath stuff @@ -571,22 +596,27 @@ dosifyPath stuff | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff | otherwise = stuff - subst a b ls = map (\ x -> if x == a then b else x) ls #else -dosifyPaths xs = xs -dosifyPath xs = xs + +--------------------- Unix version --------------------- +dosifyPath p = p +dosifyPaths ps = ps +unDosifyPath xs = subst '\\' '/' xs +-------------------------------------------------------- #endif +subst a b ls = map (\ x -> if x == a then b else x) ls +\end{code} + + ----------------------------------------------------------------------------- --- Path name construction --- At the moment, we always use '/' and rely on dosifyPath --- to switch to DOS pathnames when necessary + Path name construction +\begin{code} slash :: String -> String -> String absPath, relPath :: [String] -> String isSlash '/' = True -isSlash '\\' = True isSlash other = False relPath [] = "" @@ -594,12 +624,17 @@ relPath xs = foldr1 slash xs absPath xs = "" `slash` relPath xs -#if defined(mingw32_TARGET_OS) -slash s1 s2 = s1 ++ ('\\' : s2) -#else slash s1 s2 = s1 ++ ('/' : s2) -#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Support code} +%* * +%************************************************************************ + +\begin{code} ----------------------------------------------------------------------------- -- Define myGetProcessId :: IO Int -- getExecDir :: IO (Maybe String) @@ -625,3 +660,43 @@ getProcessID = Posix.getProcessID getExecDir :: IO (Maybe String) = do return Nothing #endif \end{code} + +%************************************************************************ +%* * +\subsection{System} +%* * +%************************************************************************ + +In GHC prior to 5.01 (or so), on Windows, the implementation +of "system" in the library System.system does not work for very +long command lines. But GHC may need to make a system call with +a very long command line, notably when it links itself during +bootstrapping. + +Solution: when compiling SysTools for Windows, using GHC prior +to 5.01, write the command to a file and use "sh" (not cmd.exe) +to execute it. Such GHCs require "sh" on the path, but once +bootstrapped this problem goes away. + +ToDo: remove when compiling with GHC < 5 is not relevant any more + +\begin{code} +system cmd + +#if !defined(mingw32_TARGET_OS) || __GLASGOW_HASKELL__ > 501 + -- The usual case + = System.system cmd + +#else -- The Hackoid case + = do pid <- getProcessID + tmp_dir <- readIORef v_TmpDir + let tmp = tmp_dir++"/sh"++show pid + h <- openFile tmp WriteMode + hPutStrLn h cmd + hClose h + exit_code <- System.system ("sh - " ++ tmp) `catchAllIO` + (\exn -> removeFile tmp >> throw exn) + removeFile tmp + return exit_code +#endif +\end{code}