[project @ 2003-06-12 16:06:05 by simonmar]

Change the type of System.Cmd.rawSystem:

  rawSystem :: FilePath -> [String] -> IO ExitCode

and implement it properly on both Windows & Unix.  The intended
meaning is that the program is executed with *exactly* these
arguments.

We now re-use this rawSystem in the compiler itself (using it directly
from the library if __GLASGOW_HASKELL__ >= 601).

The previous implementation of SysTools.runSomething was broken on
4.08, because Posix.executeFile was broken.  However, implementing the
new rawSystem on 4.08 is tricky, because it uses the FFI marshalling
libraries which weren't present on 4.08.  Hence, bootstrapping from
4.08 is now not possible (it was already not possible on Windows).  It
could be made possible by importing enough FFI marshalling support,
but I won't bother doing that unless/until it is needed.

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index c96b6ad..f10950a 100644 (file)
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -235,7 +235,7 @@ CLEAN_FILES += $(CONFIG_HS)
 ALL_DIRS = \
   utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
   specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
-  profiling parser cprAnalysis compMan ndpFlatten
+  profiling parser cprAnalysis compMan ndpFlatten cbits
 
 # Make sure we include Config.hs even if it doesn't exist yet...
 ALL_SRCS += $(CONFIG_HS)

diff --git a/ghc/compiler/cbits/rawSystem.c b/ghc/compiler/cbits/rawSystem.c
new file mode 100644 (file)
index 0000000..d103f48
--- /dev/null
+++ b/ghc/compiler/cbits/rawSystem.c
@@ -0,0 +1,6 @@
+/* Grab rawSystem from the library sources iff we're bootstrapping with an
+ * old version of GHC.
+ */
+#if __GLASGOW_HASKELL__ < 601
+#include "../../libraries/base/cbits/rawSystem.c"
+#endif

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index 3297a09..a2f0d1d 100644 (file)
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -87,19 +87,15 @@ import List             ( intersperse )
 
 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
 -- lines on mingw32, so we disallow it now.
-#if defined(mingw32_HOST_OS) && (__GLASGOW_HASKELL__ <= 408)
-#error GHC <= 4.08 is not supported for bootstrapping GHC on i386-unknown-mingw32
+#if __GLASGOW_HASKELL__ < 500
+#error GHC >= 5.00 is required for bootstrapping GHC
 #endif
 
 #ifndef mingw32_HOST_OS
 #if __GLASGOW_HASKELL__ > 504
 import qualified System.Posix.Internals
-import System.Posix.Process ( executeFile, getProcessStatus, forkProcess, ProcessStatus(..))
-import System.Posix.Signals ( installHandler, sigCHLD, sigCONT, Handler(..) )
 #else
 import qualified Posix
-import Posix ( executeFile, getProcessStatus, forkProcess, ProcessStatus(..), installHandler,
-               sigCHLD, sigCONT, Handler(..) )
 #endif
 #else /* Must be Win32 */
 import List            ( isPrefixOf )
@@ -108,12 +104,11 @@ import Foreign
 import CString         ( CString, peekCString )
 #endif
 
-#ifdef mingw32_HOST_OS
-#if __GLASGOW_HASKELL__ > 504
-import System.Cmd       ( rawSystem )
+#if __GLASGOW_HASKELL__ < 601
+import Foreign         ( withMany, withArray0, nullPtr, Ptr )
+import CForeign                ( CString, withCString, throwErrnoIfMinus1 )
 #else
-import SystemExts       ( rawSystem )
-#endif
+import System.Cmd      ( rawSystem )
 #endif
 \end{code}
 
@@ -701,51 +696,13 @@ runSomething :: String            -- For -v message
                                --      runSomething will dos-ify them
             -> IO ()
 
-runSomething phase_name pgm args
- = traceCmd phase_name (concat (intersperse " " (pgm:quoteargs))) $
-   do
-#ifdef mingw32_HOST_OS
-          let showOptions :: [Option] -> String
-              showOptions ls = unwords (map (quote . showOpt) ls)
-
-              quote :: String -> String
-              quote "" = ""
-              quote s  = "\"" ++ escapeDoubleQuotes s ++ "\""
-
-              escapeDoubleQuotes :: String -> String
-              escapeDoubleQuotes ""            = ""
-              escapeDoubleQuotes ('\\':'"':cs) = '\\':'"':escapeDoubleQuotes cs
-              escapeDoubleQuotes (     '"':cs) = '\\':'"':escapeDoubleQuotes cs
-              escapeDoubleQuotes (c       :cs) = c       :escapeDoubleQuotes cs
-
-          -- The pgm is already in native format (appropriate dir separators)
-          exit_code <- rawSystem (pgm ++ ' ':showOptions args)
-#else
-          mpid <- forkProcess
-          exit_code <- case mpid of
-            Nothing -> do -- Child
-             executeFile pgm True quoteargs Nothing
-              exitWith (ExitFailure 127)
-             -- NOT REACHED
-              return ExitSuccess
-            Just child -> do -- Parent
-#if __GLASGOW_HASKELL__ <= 504
-              -- avoid interaction with broken getProcessStatus-FFI:
-              oldHandler <- installHandler sigCONT Ignore Nothing
-#endif
-              Just (Exited res) <- getProcessStatus True False child
-#if __GLASGOW_HASKELL__ <= 504
-              -- restore handler
-              installHandler sigCONT oldHandler Nothing
-#endif
-
-              return res
-#endif
-         when (exit_code /= ExitSuccess) $
-            throwDyn (PhaseFailed phase_name exit_code)
-          return ()    
-  where
-    quoteargs = filter (not . null) (map showOpt args)
+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
+  if (exit_code /= ExitSuccess)
+       then throwDyn (PhaseFailed phase_name exit_code)
+       else return ()
 
 traceCmd :: String -> String -> IO () -> IO ()
 -- a) trace the command (at two levels of verbosity)
@@ -767,6 +724,54 @@ traceCmd phase_name cmd_line action
     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
                             ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
                             ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
+
+-- -----------------------------------------------------------------------------
+-- rawSystem: run an external command
+
+#if __GLASGOW_HASKELL__ < 601
+
+-- This code is copied from System.Cmd on GHC 6.1.
+
+rawSystem :: FilePath -> [String] -> IO ExitCode
+
+#ifndef mingw32_TARGET_OS
+
+rawSystem cmd args =
+  withCString cmd $ \pcmd ->
+    withMany withCString (cmd:args) $ \cstrs ->
+      withArray0 nullPtr cstrs $ \arr -> do
+       status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
+        case status of
+            0  -> return ExitSuccess
+            n  -> return (ExitFailure n)
+
+foreign import ccall unsafe "rawSystem"
+  c_rawSystem :: CString -> Ptr CString -> IO Int
+
+#else
+
+-- On Windows, the command line is passed to the operating system as
+-- a single string.  Command-line parsing is done by the executable
+-- itself.
+rawSystem cmd args = do
+  let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
+  withCString cmdline $ \pcmdline -> do
+    status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
+    case status of
+       0  -> return ExitSuccess
+       n  -> return (ExitFailure n)
+
+translate :: String -> String
+translate str = '"' : foldr escape "\"" str
+  where escape '"'  str = '\\' : '"'  : str
+       escape '\\' str = '\\' : '\\' : str
+       escape c    str = c : str
+
+foreign import ccall unsafe "rawSystem"
+  c_rawSystem :: CString -> IO Int
+
+#endif
+#endif
 \end{code}