-- 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
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 )
%* *
%************************************************************************
+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
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<dir> option")
+ ; case maybe_exec_dir of -- (only works on Windows;
+ -- returns Nothing on Unix)
+ Nothing -> throwDyn (InstallationError "missing -B<dir> 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
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`
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)
%************************************************************************
%* *
-\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
| 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 [] = ""
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)
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}
projects / ghc-hetmet.git / blobdiff